;;; Windows that hack the network -*- Mode:LISP; Package:SUPDUP; BASE: 8 -*-

;;; "Connect to:" may be answered by hostname, bridgehostname, bridgehostname/socket,
;;; or hostname/contactname.

(DEFFLAVOR BASIC-NVT
           ((ESCAPE-CHAR #/NETWORK)     ;Escape character (in Lisp machine character set)
            (CONNECTION NIL)            ;The connection itself
            (CONNECT-TO NIL)            ;Host to connect to (for TYPEIN-TOP-LEVEL)
            STREAM                      ;A stream to the above
            (TERMINAL-STREAM NIL)       ;Stream for output. If NIL, (which is the usual case)
                                        ; output to SELF.
            (OUTPUT-BUFFER (MAKE-STRING #o200 :FILL-POINTER 0))
            TYPEOUT-PROCESS             ;Network to screen
            TYPEIN-PROCESS              ;Keyboard to network
            (OUTPUT-LOCK NIL)           ;Some typeout occurs in TYPEIN-PROCESS
            (RETURN-TO-CALLER NIL)      ;Set to T when :TYPEIN-TOP-LEVEL should return
            (OVERPRINT T)               ;NIL means erase chars before outputing.
            (BLACK-ON-WHITE NIL)
            (ALIAS-WINDOW NIL)          ;Our :ALIAS-FOR-SELECTED-WINDOWS, if non-NIL.
            PROGRAM-NAME)               ;In the "Connect to host" message and help message.
            ()
  (:REQUIRED-FLAVORS TV:LABEL-MIXIN TV:STREAM-MIXIN TV:SHEET)
  (:GETTABLE-INSTANCE-VARIABLES CONNECTION STREAM OUTPUT-BUFFER ALIAS-WINDOW)
  (:INITABLE-INSTANCE-VARIABLES ESCAPE-CHAR TYPEIN-PROCESS TYPEOUT-PROCESS PROGRAM-NAME)
  (:SETTABLE-INSTANCE-VARIABLES CONNECT-TO TERMINAL-STREAM BLACK-ON-WHITE)
  (:REQUIRED-METHODS :CONNECT :GOBBLE-GREETING :NET-OUTPUT :NET-OUTPUT-TRANSLATED)
  (:DEFAULT-INIT-PLIST :DEEXPOSED-TYPEOUT-ACTION ':NOTIFY)
  (:DOCUMENTATION :SPECIAL-PURPOSE "Network virtual terminal windows"))

(DEFMETHOD (BASIC-NVT :BUFFERED-TYO) (CH)
  (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
    (SEND SELF ':FORCE-OUTPUT)))

(DEFMETHOD (BASIC-NVT :FORCE-OUTPUT) ()
  (LET-GLOBALLY-IF BLACK-ON-WHITE
                   ((TV:CHAR-ALUF TV:ERASE-ALUF))
    (TV:SHEET-STRING-OUT SELF OUTPUT-BUFFER))
  (STORE-ARRAY-LEADER 0 OUTPUT-BUFFER 0))

(DEFMETHOD (BASIC-NVT :ALIAS-FOR-SELECTED-WINDOWS) ()
  (OR ALIAS-WINDOW
      (AND TV:SUPERIOR (SEND TV:SUPERIOR ':ALIAS-FOR-INFERIORS))
      SELF))

(DEFFLAVOR BASIC-SUPDUP () (BASIC-NVT GRAPHICS-MIXIN TV:FULL-SCREEN-HACK-MIXIN)
  (:DEFAULT-INIT-PLIST :PROGRAM-NAME "Supdup")
  (:DOCUMENTATION :SPECIAL-PURPOSE "A SUPDUP NVT"))

(DEFFLAVOR SUPDUP () (BASIC-SUPDUP TV:INITIALLY-INVISIBLE-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  (:DOCUMENTATION :COMBINATION))

(DEFMACRO LOCK-OUTPUT BODY
  `(UNWIND-PROTECT
     (PROGN
       (PROCESS-LOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))
       . ,BODY)
     (COND ((EQ CURRENT-PROCESS OUTPUT-LOCK)
            (PROCESS-UNLOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))))))

(DEFMETHOD (BASIC-NVT :SET-SUPER-IMAGE-MODE) (FLAG)
  (COND (FLAG
         (SETF (TV:IO-BUFFER-OUTPUT-FUNCTION TV:IO-BUFFER) NIL)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER))
                  NIL
                  ':ASYNCHRONOUS-CHARACTERS)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER)) T ':SUPER-IMAGE)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER)) T ':DONT-UPCASE-CONTROL-CHARACTERS))
        (T
         (SETF (TV:IO-BUFFER-OUTPUT-FUNCTION TV:IO-BUFFER) 'TV:KBD-DEFAULT-OUTPUT-FUNCTION)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER))
                  TV:KBD-STANDARD-ASYNCHRONOUS-CHARACTERS
                  ':ASYNCHRONOUS-CHARACTERS)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER)) NIL ':SUPER-IMAGE)
         (PUTPROP (LOCF (TV:IO-BUFFER-PLIST TV:IO-BUFFER)) NIL
                  ':DONT-UPCASE-CONTROL-CHARACTERS))))


;The following is just like TV:PROCESS-MIXIN except that there are two processes
;Also we have to provide for the two I/O buffers
(DEFMETHOD (BASIC-NVT :AFTER :INIT) (IGNORE)
  (UNLESS (VARIABLE-BOUNDP TYPEOUT-PROCESS)
    (SETQ TYPEOUT-PROCESS (MAKE-PROCESS (STRING-APPEND TV:NAME "-Typeout")
                                        ':SPECIAL-PDL-SIZE 2000.))
    (PROCESS-PRESET TYPEOUT-PROCESS SELF ':TYPEOUT-TOP-LEVEL))
  (UNLESS (VARIABLE-BOUNDP TYPEIN-PROCESS)
    (SETQ TYPEIN-PROCESS (MAKE-PROCESS (STRING-APPEND TV:NAME "-Typein")
                                       ':SPECIAL-PDL-SIZE 2000.))
    (PROCESS-PRESET TYPEIN-PROCESS 'TYPEIN-TOP-LEVEL SELF))
  (SEND SELF ':SET-LABEL (FORMAT NIL "~A -- not connected" TV:NAME)))

;Delay starting up processes until they start to get used, to save paging on cold-boot
(DEFMETHOD (BASIC-NVT :BEFORE :SELECT) (&REST IGNORE)
  (MAYBE-RESET-PROCESS TYPEIN-PROCESS)
  (MAYBE-RESET-PROCESS TYPEOUT-PROCESS))

(DEFMETHOD (BASIC-NVT :BEFORE :EXPOSE) (&REST IGNORE)
  (MAYBE-RESET-PROCESS TYPEIN-PROCESS)
  (MAYBE-RESET-PROCESS TYPEOUT-PROCESS))

;; Not patched in 94 due to SI:FLUSHED-PROCESS
(DEFUN MAYBE-RESET-PROCESS (PROCESS)
  (COND ((AND PROCESS (TYPEP PROCESS 'SI:PROCESS))
         (AND (EQ (PROCESS-WAIT-FUNCTION PROCESS) 'SI:FLUSHED-PROCESS)
              (SEND PROCESS ':RESET))
         (SEND PROCESS ':RUN-REASON SELF))))

;; Return a list of our extra processes to be killed.
(DEFMETHOD (BASIC-NVT :PROCESSES) ()
  (APPEND (AND TYPEIN-PROCESS (LIST TYPEIN-PROCESS))
          (AND TYPEOUT-PROCESS (LIST TYPEOUT-PROCESS))))

(DEFMETHOD (BASIC-NVT :AFTER :REFRESH) (&OPTIONAL IGNORE)
  (OR TV:RESTORED-BITS-P (SEND SELF ':HOME-CURSOR)))

(DEFMETHOD (BASIC-NVT :CONNECTED-P) ()
  (AND CONNECTION (EQ (CHAOS:STATE CONNECTION) 'CHAOS:OPEN-STATE)))

(DEFMETHOD (BASIC-NVT :BEFORE :CONNECT) (&REST IGNORE)
  (IF CONNECTION
      (SEND SELF ':DISCONNECT)
      (FS:FORCE-USER-TO-LOGIN)))

(DEFMETHOD (BASIC-NVT :AFTER :SET-CONNECT-TO) (&REST IGNORE)
  (AND TYPEIN-PROCESS (SEND TYPEIN-PROCESS ':RESET)))

(DEFMETHOD (BASIC-NVT :NEW-CONNECTION) (HOST GATEWAY CONTACT CONTACT-P WINDOW
                                        &AUX LABEL-SPEC CONN)
  (MULTIPLE-VALUE (HOST CONTACT LABEL-SPEC)
    (EXPAND-PATH TV:NAME HOST GATEWAY CONTACT CONTACT-P))
  (SETQ CONN (CHAOS:CONNECT HOST CONTACT WINDOW))
  (IF (ERRORP CONN)
      CONN
    (SEND SELF ':SET-LABEL LABEL-SPEC)
    (SEND SELF ':SET-CONNECTION CONN)
    CONN))

;;; Path may be any of these:
;;; NIL: Use associated machine.
;;; a fixnum: Use the host whose Chaos address is that number.
;;; host-name: Use that host.
;;; gateway-host-nameinternet-host-name: Use that gateway and arpa host.
;;; host-name/contact-string: Use that chaos host and that contact string.
;;; internet-host-name/number: Use that Internet host and that socket.
;;; gateway-host-nameinternet-host-name/number: (Obvious.)
;;;  The ARPA-SOCKET and CONNECT-NAME arguments are overriden by the above.
;;;  Socket numbers are in octal.
(DEFUN PARSE-PATH (PATH CONTACT-NAME ARPA-SOCKET)
  (DECLARE (RETURN-LIST HOST GATEWAY-HOST CONTACT CONTACT-SPECIFIED-P))
  (AND (SYMBOLP PATH)
       (SETQ PATH (STRING PATH)))
  (LET ((HOST NIL)
        (GATEWAY NIL)
        (SPECIFIED-CONTACT NIL))
    (COND ((FIXP PATH)
           ;; Allow an unknown number through
           (OR (SETQ HOST (SI:GET-HOST-FROM-ADDRESS PATH ':CHAOS))
               (SETQ HOST PATH)))
          ((NULL PATH)
           (SETQ HOST SI:ASSOCIATED-MACHINE))
          ((NOT (STRINGP PATH))
           (SETQ HOST PATH))
          (T
           (LET ((GATE-P (STRING-SEARCH-CHAR #/ PATH)))
             (COND ((NOT GATE-P)
                    (LET ((SLASH-P (STRING-SEARCH-CHAR #// PATH)))
                      (IF (NOT SLASH-P)
                          ;; Format is "host-name".
                          (IF (LET ((HST (SI:PARSE-HOST PATH T)))
                                (AND HST (SEND HST ':NETWORK-TYPEP ':CHAOS)))
                              (SETQ HOST PATH)
                              (LET ((NUMBER (PARSE-NUMBER PATH 0 NIL 8 T)))
                                (IF NUMBER
                                    (OR (SETQ HOST (SI:GET-HOST-FROM-ADDRESS NUMBER ':CHAOS))
                                        (SETQ HOST NUMBER))
                                    ;; Attempt to get info on an arpa host, but don't lose
                                    ;; if no network host table servers available.
                                    (SETQ HOST PATH
                                          GATEWAY T))))
                          (LET ((NUMBER (PARSE-NUMBER PATH (1+ SLASH-P) NIL 10. T)))
                            (IF (NULL NUMBER)
                                ;; Format is "host-name/contact-string".
                                (SETQ HOST (SUBSTRING PATH 0 SLASH-P)
                                      SPECIFIED-CONTACT (SUBSTRING PATH (1+ SLASH-P)))
                                ;; Format is "internet-host-name/number".
                                (SETQ HOST (SUBSTRING PATH 0 SLASH-P)
                                      GATEWAY T
                                      SPECIFIED-CONTACT NUMBER))))))
                   (T
                    (SETQ GATEWAY (SUBSTRING PATH 0 GATE-P))
                    (LET ((SLASH-P (STRING-SEARCH-CHAR #// PATH (1+ GATE-P))))
                      (IF (NOT SLASH-P)
                          ;; Format is "gateway-host-nameinternet-host-name".
                          (SETQ HOST (SUBSTRING PATH (1+ GATE-P)))
                          ;; Format is "gateway-host-nameinternet-host-name/number".
                          (LET ((NUMBER-P (PARSE-NUMBER PATH (1+ SLASH-P) NIL 10. T)))
                            (IF (NULL NUMBER-P)
                                (FERROR "~S is not a meaninful specification" PATH))
                            (SETQ HOST (SUBSTRING PATH (1+ GATE-P) SLASH-P)
                                  SPECIFIED-CONTACT NUMBER-P)))))))))
    (COND (GATEWAY
           (AND (EQ GATEWAY T)
                (SETQ GATEWAY (CAR (SI:GET-SITE-OPTION ':ARPA-GATEWAYS))))
           (SETQ GATEWAY (SI:PARSE-HOST GATEWAY))
           (SETQ HOST (OR (SI:PARSE-HOST HOST T T) HOST)))
          ((STRINGP HOST)
           (SETQ HOST (SI:PARSE-HOST HOST))))
    (VALUES HOST GATEWAY
            (OR SPECIFIED-CONTACT (IF GATEWAY ARPA-SOCKET CONTACT-NAME))
            (NOT (NULL SPECIFIED-CONTACT)))))

(DEFVAR *CHAOS-ARPA-CONTACT-NAME* "TCP"
  "Contact name to use to go thru gateways into the arpanet.
Defaults to TCP, as of January 1, 1983.  If your site loses,
try binding this variable to /"NCP/"")

(DEFUN EXPAND-PATH (PROGNAME HOST GATEWAY-HOST CONTACT CONTACT-P &AUX LABEL)
  (DECLARE (RETURN-LIST CHAOS-HOST CONTACT LABEL))
  (SETQ LABEL (FORMAT NIL "~A -- ~@[~A  ~]~A~:[ (~:[~A~;~O~])~]"
                      PROGNAME GATEWAY-HOST HOST (NOT CONTACT-P) GATEWAY-HOST CONTACT))
  (VALUES (OR GATEWAY-HOST HOST)
          (IF GATEWAY-HOST
              (FORMAT NIL "~A ~A ~O" *CHAOS-ARPA-CONTACT-NAME* HOST CONTACT)
            CONTACT)
          LABEL))

(DEFMETHOD (BASIC-NVT :SET-CONNECTION) (NEW-CONNECTION)
  (SEND TYPEIN-PROCESS ':RESET)
  (SEND TYPEOUT-PROCESS ':RESET)
  (SETQ STREAM (CHAOS:MAKE-STREAM NEW-CONNECTION ':characters nil))
  (SEND SELF ':GOBBLE-GREETING)
;; Typeout process initially waits to see CONNECTION non-NIL.
  (SETQ CONNECTION NEW-CONNECTION)
  (SETQ BLACK-ON-WHITE NIL))

(recompile-flavor 'basic-nvt)

(DEFMETHOD (BASIC-NVT :DISCONNECT) ()
  (SEND TYPEIN-PROCESS ':FLUSH)
  (SEND TYPEOUT-PROCESS ':FLUSH)
  (COND (CONNECTION
         (CHAOS:CLOSE-CONN CONNECTION)
         (CHAOS:REMOVE-CONN CONNECTION)
         (SETQ CONNECTION NIL)))
  (SEND TYPEIN-PROCESS ':RESET)
  (SEND TYPEOUT-PROCESS ':RESET))

;;;This is the typein process
(DEFUN TYPEIN-TOP-LEVEL (WINDOW)
  (DO () (())
    (SEND WINDOW ':TYPEIN-TOP-LEVEL)
    (TV:DESELECT-AND-MAYBE-BURY-WINDOW WINDOW)))

(DEFMETHOD (BASIC-NVT :TYPEIN-TOP-LEVEL) (&OPTIONAL (TOP-LEVEL-P T) &AUX (TERMINAL-IO SELF))
  (DO ((STR NIL NIL)) (NIL)
    (SETQ RETURN-TO-CALLER NIL)
    (SETQ STR ':ABORT)
    (CATCH-ERROR-RESTART-IF TOP-LEVEL-P ((SYS:ABORT ERROR) "Return to command level; optionally disconnect.")
      (SETQ STR
            (*CATCH 'NVT-DONE
                (COND ((NOT (NULL CONNECTION))
                       (SEND SELF ':SET-SUPER-IMAGE-MODE T)
                       (CONDITION-BIND ((SYS:REMOTE-NETWORK-ERROR
                                          'NET-ERROR))
                         (DO ((CH)) (NIL)
                           (OR (SEND SELF ':LISTEN)
                               (LOCK-OUTPUT
                                 (SEND STREAM ':FORCE-OUTPUT)))
                           (SETQ CH (SEND SELF ':ANY-TYI))
                           (IF (CONSP CH)
                               (SELECTQ (CAR CH)
                                 (:ERROR (*THROW 'NVT-DONE (CADR CH)))
                                 (:MORE (SEND SELF ':MORE-TYI))
                                 (OTHERWISE
                                  (SEND SELF ':NET-OUTPUT-TRANSLATED CH)))
                             (SELECTQ (CHAOS:STATE CONNECTION)
                               (CHAOS:OPEN-STATE)
                               (CHAOS:HOST-DOWN-STATE
                                (*THROW 'NVT-DONE "Foreign Host died"))
                               (CHAOS:CLS-RECEIVED-STATE
                                (*THROW 'NVT-DONE "Closed by foreign host"))
                               (CHAOS:LOS-RECEIVED-STATE
                                (*THROW 'NVT-DONE "Connection closed due to lossage:"))
                               (OTHERWISE
                                (*THROW 'NVT-DONE
                                        (FORMAT NIL "Connection in unknown state:~S"
                                                (CHAOS:STATE CONNECTION)))))
                             (IF (= (CHAR-UPCASE CH) ESCAPE-CHAR)
                                 ;;Handle the escape character,
                                 (SEND SELF ':HANDLE-ESCAPE)
                               ;; otherwise just send through what user typed.
                               (SEND SELF ':NET-OUTPUT-TRANSLATED CH))))))
                      (CONNECT-TO
                       (SEND SELF ':CLEAR-SCREEN)
                       (CONDITION-CASE (ERROR)
                           (SEND SELF ':CONNECT (PROG1 CONNECT-TO
                                                          (SETQ CONNECT-TO NIL)))
                         (SYS:REMOTE-NETWORK-ERROR ERROR)))
                      (T (SEND SELF ':SET-SUPER-IMAGE-MODE NIL)
                         (LET ()
                           (BIND (LOCF (TV:IO-BUFFER-OUTPUT-FUNCTION TV:IO-BUFFER))
                                 'SUPDUP-IO-BUFFER-OUTPUT-FUNCTION)
                           (DO () (())
                             ;; Loop until loser types in something non-blank.
                             (FORMAT T "~&~A.  Type the HELP key for help.~@
                                      Connect to host: " PROGRAM-NAME)
                             (LET ((HOST-NAME (STRING-TRIM  '(#/SPACE #/TAB) (READLINE))))
                               (COND ((PLUSP (STRING-LENGTH HOST-NAME))
                                      (RETURN
                                        (CONDITION-CASE (ERROR)
                                            (SEND SELF ':CONNECT HOST-NAME)
                                          (SYS:REMOTE-NETWORK-ERROR ERROR)))))))))))))
    (IF (AND (ERRORP STR) (NOT (STRINGP STR)))
        (SETQ STR (SEND STR ':REPORT-STRING)))
    (IF (EQ STR ':ABORT)
        (SETQ STR (IF (AND CONNECTION (Y-OR-N-P "Disconnect the SUPDUP connection? "))
                      "Connection aborted" NIL)))
    (COND ((STRINGP STR)
           (SEND SELF ':DISCONNECT)
           (FORMAT SELF "~%~A~%" STR)
           (AND RETURN-TO-CALLER (RETURN T))))))

(DEFVAR INHIBIT-TOP-LEVEL-HELP NIL)

;;; This is used as the I/O buffer output function while reading a hostname.
;;; It intercepts Help and Network, as well as the usual things.
(DEFUN SUPDUP-IO-BUFFER-OUTPUT-FUNCTION (IGNORE CHAR)
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (COND ((NOT (NUMBERP CHAR)) CHAR)             ;Blips shouldn't get here, but don't die
        ((AND (EQ CHAR #/HELP)
              (NOT INHIBIT-TOP-LEVEL-HELP))     ;T if recursive, from clause below.
         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
         (TV:OUTPUT-BEFORE-RUBOUT-HANDLER (SELF)
           (SEND SELF ':HELP-MESSAGE))
         (VALUES CHAR T))
        ((= (CHAR-UPCASE CHAR) ESCAPE-CHAR)
         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
         (LET ((INHIBIT-TOP-LEVEL-HELP T))
           (SEND SELF ':HANDLE-ESCAPE))
         (VALUES CHAR T))
        (T (LET ((TEM (ASSQ CHAR TV:KBD-INTERCEPTED-CHARACTERS)))
             (IF TEM (FUNCALL (CADR TEM) CHAR)
               CHAR)))))

;;; Call this before inputting things.  It peeks for an escape and handles it.
(DEFMETHOD (BASIC-NVT :ALLOW-ESCAPE) ()
  (DO ()
      ((LET ((CHAR (SEND STANDARD-INPUT ':ANY-TYI)))
         (COND ((AND (NUMBERP CHAR)
                     (= (CHAR-UPCASE CHAR) ESCAPE-CHAR))
                (SEND SELF ':HANDLE-ESCAPE)     ; Handle the escape character.
                NIL)                            ; Keep looping.
               ((AND (NUMBERP CHAR)
                     (= CHAR #/HELP))
                (SEND SELF ':HELP-MESSAGE)      ; Give the user some help.
                NIL)                            ; Keep looping.
               (T
                (SEND SELF ':UNTYI CHAR)        ; Put back character, exit loop.
                T)))
       NIL)))

;;; Default help message.
(DEFMETHOD (BASIC-NVT :HELP-MESSAGE)
           (&AUX (FORMAT-ARGS
                   (LIST "~
~&You are using the ~A remote-login program.
To connect to any Chaosnet or Internet host, just type the target host name.
If you want to connect to an Internet host and specify a particular gateway
host, type the gateway host name, an altmode, and the target host name.
If you want to connect to a specific socket on an Internet host, follow
the name of the Internet host by a slash and the socket number in octal.
If you want to connect to a specific connect-name on a Chaosnet host,
follow the name of the Chaosnet host by a slash and the connect name.

Summary:
  host      (for either network)
  gatewayinternet-host
  chaos-host//connect-name
  internet-host//socket-number (octal)
  gatewayinternet-host//socket-number (octal)

At any time you can type the [Network] key to give any of a number of useful
commands.  For descriptions of the available commands, type [Network] [Help].

Connect to host: "
                         PROGRAM-NAME)))
  (DECLARE (SPECIAL FORMAT-ARGS))
  (COND ((NULL CONNECTION)
         (SEND STANDARD-OUTPUT ':CLEAR-SCREEN)
         (APPLY 'FORMAT T FORMAT-ARGS))
        (T
         (SI:WITH-HELP-STREAM (HELP-STREAM :LABEL "Keyboard system commands")
           (APPLY 'FORMAT HELP-STREAM FORMAT-ARGS)))))

;;;Condition handler for typein side.
(DEFUN NET-ERROR (CONDITION)
  (*THROW 'NVT-DONE (SEND CONDITION ':REPORT-STRING)))

(DEFMETHOD (BASIC-NVT :TOGGLE-OVERPRINTING) ()
  (SETQ OVERPRINT (NOT OVERPRINT)))

;;;Handle a command to the SUPDUP program itself.
(DEFMETHOD (BASIC-NVT :HANDLE-ESCAPE) (&AUX CH XPOS YPOS)
  (UNWIND-PROTECT
    (PROGN
      (MULTIPLE-VALUE (XPOS YPOS) (TV:SHEET-READ-CURSORPOS SELF))
      (PUT-DOWN-STRING SELF "CMND-->")
      (SETQ CH (CHAR-UPCASE (SEND SELF ':TYI)))
      (SELECTQ CH
        ((#/CALL #/P)
         (TV:DESELECT-AND-MAYBE-BURY-WINDOW SELF))
        (#/A
         (IF (NOT (NULL CONNECTION))
             (SEND SELF ':SEND-IF-HANDLES ':SEND-IP)))
        ((#/B #/BREAK)
         (SEND SELF ':SET-SUPER-IMAGE-MODE NIL)
         (BREAK "BREAK")
         (SEND SELF ':SET-SUPER-IMAGE-MODE T))
        (#/C                          ;C = Change escape character.
         (PUT-DOWN-STRING SELF "Change escape character to -->")
         (SEND SELF ':SET-SUPER-IMAGE-MODE NIL)
         (SETQ ESCAPE-CHAR (CHAR-UPCASE (SEND SELF ':TYI)))
         (SEND SELF ':SET-SUPER-IMAGE-MODE T))
        (#/D                         ;D = Disconnect, ask for new host to connect to.
         (COND ((NULL CONNECTION)
                (*THROW 'NVT-DONE "(Already disconnected.)"))
               (T
                (SEND SELF ':DISCONNECT)
                (*THROW 'NVT-DONE "Disconnected"))))
        (#/E
         (SEND SELF ':SET-SUPER-IMAGE-MODE NIL))
        (#/L                          ;L = Logout.
         (COND ((NULL CONNECTION)
                (QUIT))
               (T
                (SEND SELF ':LOGOUT)
                (QUIT "Logout"))))
        (#/Q                          ;Q = Quit.
         (QUIT))
        (#/M                          ;M = More.
         (IF (NOT (NULL CONNECTION))
             (SEND SELF ':SEND-IF-HANDLES ':USER-SET-MORE-P
                           (NOT (SEND SELF ':MORE-P)))))
        (#/I                          ;I = Imlac.
         (IF (NOT (NULL CONNECTION))
             (SEND SELF ':SEND-IF-HANDLES ':TOGGLE-IMLAC-SIMULATION)))
        (#/O
         (SEND SELF ':SEND-IF-HANDLES ':TOGGLE-OVERPRINTING))
        ((#/HELP #/?)                 ;<HELP> or ? = Help
         (SI:WITH-HELP-STREAM (WINDOW :LABEL "Help for Network commands")
           (SEND WINDOW ':CLEAR-SCREEN)
           (FORMAT WINDOW "After typing the Escape character, which is ~:C,
you can type these commands:~%" ESCAPE-CHAR)
           (FORMAT WINDOW "
CALL -- Do a local CALL (return to top window).
BREAK-- Enter a breakpoint.
~:[~;A    -- Send an ATTN (in Telnet, a New Telnet /"Interrupt Process/").
~]~
C    -- Change the SUPDUP escape character.
D    -- Disconnect and connect to new host.
~:[~;I    -- Toggle imlac simulation.
~]~
L    -- Log out of remote host, and break the connection.
~:[~;M    -- Toggle more processing.
~]~
~:[~;O    -- Toggle overprinting (for servers that expect non-overprinting terminals).
~]~
P    -- Return to top window, but don't break connection.
Q    -- Disconnect and return to top window.

Help -- Type this cruft.
"
                   (GET-HANDLER-FOR SELF ':SEND-IP)
                   (GET-HANDLER-FOR SELF ':TOGGLE-IMLAC-SIMULATION)
                   (GET-HANDLER-FOR SELF ':USER-SET-MORE-P)
                   (GET-HANDLER-FOR SELF ':TOGGLE-OVERPRINTING))
           (FORMAT WINDOW "~4A -- Send ~:C through~%"
                   (FORMAT NIL "~:C" ESCAPE-CHAR)
                   ESCAPE-CHAR)))
        (#/RUBOUT)                              ;<RUBOUT> = Do nothing.
        (OTHERWISE
          (COND ((= CH ESCAPE-CHAR)
                 (SEND SELF ':NET-OUTPUT-TRANSLATED CH)
                 (LOCK-OUTPUT
                   (SEND STREAM ':FORCE-OUTPUT)))
                (T (TV:BEEP))))))
    (TV:SHEET-FORCE-ACCESS (SELF T)
      (PUT-DOWN-STRING SELF "")      ;Clear the bottom line.
      (TV:SHEET-SET-CURSORPOS SELF XPOS YPOS))))

(DEFUN QUIT (&OPTIONAL (STRING "Quit"))
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (SEND SELF ':DISCONNECT)
  (SETQ RETURN-TO-CALLER T)
  (*THROW 'NVT-DONE STRING))

(DEFUN PUT-DOWN-STRING (SHEET STRING)
  (SEND SHEET ':HOME-DOWN)
  (TV:SHEET-CLEAR-EOL SHEET)
  (TV:SHEET-STRING-OUT SHEET STRING))

;;; In the typeout process, this is bound to the SUPDUP window.
(DEFVAR SUPDUP-WINDOW)

;;; This is the output process.
;;; We leave *TERMINAL-IO* as the background stream because having it be the SUPDUP
;;; window wedges things when this process gets an error.
(DEFMETHOD (BASIC-NVT :TYPEOUT-TOP-LEVEL) (&AUX (SUPDUP-WINDOW SELF))
  (PROCESS-WAIT "Never-open" #'CAR (LOCATE-IN-INSTANCE SELF 'CONNECTION))
  (CONDITION-BIND ((SYS:REMOTE-NETWORK-ERROR
                    'TYPEOUT-NET-ERROR))
    (DO ((OUTPUT-FUN (OR TERMINAL-STREAM (GET-HANDLER-FOR SELF ':BUFFERED-TYO))))
        (NIL)
      (DO ((CH (NVT-NETI) (SEND STREAM ':TYI-NO-HANG)))
          ((NULL CH)
           (OR TERMINAL-STREAM (SEND SELF ':FORCE-OUTPUT)))
        ;; If not buffered, clear each char pos before we output it.
        ;; (If buffered, our :before :force-output will do it).
        (IF (OR BLACK-ON-WHITE (NOT OVERPRINT))
            (IF TERMINAL-STREAM
                (SEND OUTPUT-FUN ':CLEAR-CHAR CH)))
        (SEND OUTPUT-FUN ':TYO CH)))))

(DEFMETHOD (BASIC-NVT :BEFORE :FORCE-OUTPUT) ()
  (LET-GLOBALLY-IF BLACK-ON-WHITE
                   ((TV:ERASE-ALUF TV:CHAR-ALUF))
    (IF (OR BLACK-ON-WHITE (NOT OVERPRINT))
        (TV:SHEET-CLEAR-STRING SELF OUTPUT-BUFFER))))

(DEFVAR LOG-STREAM NIL)

(DEFUN NVT-NETI (&AUX CH)
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (COND ((SETQ CH (SEND STREAM ':TYI))
         (WHEN LOG-STREAM
           (LET ((*STANDARD-OUTPUT* LOG-STREAM))
             (IF ( CH #O200) (PRIN1 CH)
                 (FORMAT:OCHAR CH :EDITOR))))
         CH)
        (T
         (SEND SUPDUP-WINDOW ':FORCE-KBD-INPUT '(:ERROR "Closed by foreign host"))
         (PROCESS-WAIT "Connection closed" #'FALSE))))

(DEFUN TYPEOUT-NET-ERROR (CONDITION)
  (SEND SUPDUP-WINDOW ':FORCE-KBD-INPUT
        (LIST ':ERROR (SEND CONDITION ':REPORT-STRING)))
  (SI:PROCESS-WAIT-FOREVER))

(DEFMETHOD (BASIC-NVT :REMOTE-BEEP) ()
  (TV:PREPARE-SHEET (SELF))                     ;Modular way to deal with output hold.
;  (OR (ZEROP (TV:SHEET-EXCEPTIONS))            ;Subject to output holding
;      (TV:SHEET-HANDLE-EXCEPTIONS SELF))
  (COND ((OR (MEMQ (SEND SELF ':STATUS) '(:EXPOSED :SELECTED))
             (EQ (SEND SELF ':DEEXPOSED-TYPEIN-ACTION)
                 ':NOTIFY))             ;If he wants notify on type-in, "notify" on beep.
         (SEND SELF ':BEEP 'SUPDUP:TERMINAL-BELL))))

;;; Suppress notification if we do not have a connection
(DEFMETHOD (BASIC-NVT :NOTICE) (EVENT &REST IGNORE)
  (AND (MEMQ EVENT '(:INPUT :OUTPUT))
       (NOT CONNECTION)))

;;;; SUPDUP Graphics Protocol

(DEFFLAVOR GRAPHICS-MIXIN (GRAPHICS-X-OFFSET GRAPHICS-Y-OFFSET
                           GRAPHICS-VIRT-SCALE
                           GRAPHICS-XPOS GRAPHICS-YPOS
                           GRAPHICS-LEFT GRAPHICS-TOP
                           GRAPHICS-RIGHT GRAPHICS-BOTTOM
                           GRAPHICS-XOR-MODE GRAPHICS-VIRTUAL-MODE)
  ()
  (:INCLUDED-FLAVORS TV:SHEET))

;;; Note that ALL four edge coordinates are INCLUSIVE:
;;; they are values corresponding to points which actually exist.
;;; This is in contrast to the window system,
;;; in which the lower limits are inclusive and the upper are exclusive.

(DEFMETHOD (GRAPHICS-MIXIN :AFTER :INIT) (&REST IGNORE)
  (GRAPHICS-RESET SELF)
  (SETQ GRAPHICS-XPOS 0 GRAPHICS-YPOS 0))

;;; Initialize all the variables used for graphics commands.
(DEFUN GRAPHICS-RESET (WINDOW)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (LET ((CORRECTED-RIGHT (+ (TV:SHEET-INSIDE-LEFT WINDOW)
                              (* (TV:SHEET-CHAR-WIDTH WINDOW)
                                 (TRUNCATE (TV:SHEET-INSIDE-WIDTH WINDOW)
                                           (TV:SHEET-CHAR-WIDTH WINDOW)))))
          (CORRECTED-BOTTOM (+ (TV:SHEET-INSIDE-TOP WINDOW)
                               (* (TV:SHEET-LINE-HEIGHT WINDOW)
                                  (TRUNCATE (TV:SHEET-INSIDE-HEIGHT WINDOW)
                                            (TV:SHEET-LINE-HEIGHT WINDOW))))))
      (SETQ GRAPHICS-X-OFFSET (TRUNCATE (+ (TV:SHEET-INSIDE-LEFT WINDOW) CORRECTED-RIGHT) 2)
            GRAPHICS-Y-OFFSET (TRUNCATE (+ (TV:SHEET-INSIDE-TOP WINDOW) CORRECTED-BOTTOM) 2)
            GRAPHICS-XPOS 0
            GRAPHICS-YPOS 0
            GRAPHICS-VIRT-SCALE (// (MIN (- CORRECTED-RIGHT (TV:SHEET-INSIDE-LEFT WINDOW))
                                         (- CORRECTED-BOTTOM (TV:SHEET-INSIDE-TOP WINDOW)))
                                    2.0S0
                                    #o4000)
            GRAPHICS-XOR-MODE NIL
            GRAPHICS-VIRTUAL-MODE NIL
            GRAPHICS-LEFT (- (TV:SHEET-INSIDE-LEFT WINDOW) GRAPHICS-X-OFFSET)
            GRAPHICS-RIGHT (- (TV:SHEET-INSIDE-RIGHT WINDOW) GRAPHICS-X-OFFSET 1)
            GRAPHICS-BOTTOM (- GRAPHICS-Y-OFFSET (1- (TV:SHEET-INSIDE-BOTTOM WINDOW)))
            GRAPHICS-TOP (- GRAPHICS-Y-OFFSET (TV:SHEET-INSIDE-TOP WINDOW)))))

(DEFVAR GRAPHICS-DISPATCH (MAKE-ARRAY 100))
(FILLARRAY GRAPHICS-DISPATCH
  '(GRAPHICS-NOTHING GRAPHICS-MOVE GRAPHICS-XOR GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING
    GRAPHICS-ERASE-SCREEN GRAPHICS-PUSH GRAPHICS-VIRTUAL GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-LIMIT GRAPHICS-NOTHING GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-MOVE GRAPHICS-IOR GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-PHYSICAL GRAPHICS-NOTHING
    GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING))

(DEFVAR DRAW-DISPATCH (MAKE-ARRAY #o20))
(FILLARRAY DRAW-DISPATCH
  '(GRAPHICS-NOTHING GRAPHICS-DRAW-LINE GRAPHICS-DRAW-POINT GRAPHICS-DRAW-RECT
    GRAPHICS-DRAW-STRING GRAPHICS-DRAW-BITS GRAPHICS-DRAW-RUNS GRAPHICS-NOTHING))

(DEFUN SUPDUP-GRAPHICS (WINDOW)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (*CATCH 'SUPDUP-GRAPHICS
    (DO (CH) (())
      (SETQ CH (GRAPHICS-NETI))
      (COND ((BIT-TEST CH #o100)
             (FUNCALL (OR (AREF DRAW-DISPATCH (LOGAND CH #o17))
                          'GRAPHICS-NOTHING)
                      WINDOW CH))
            (T
             (FUNCALL (OR (AREF GRAPHICS-DISPATCH CH)
                          'GRAPHICS-NOTHING)
                      WINDOW CH))))))


;;;; Subroutines for graphics commands.

(DEFUN GRAPHICS-NETI ()
  (DECLARE (:SELF-FLAVOR BASIC-SUPDUP))
  (LET ((CH (NVT-NETI)))
    (AND (BIT-TEST CH #o200)
         (*THROW 'SUPDUP-GRAPHICS
                 (SEND STREAM ':UNTYI CH)))
    CH))

(DEFUN GRAPHICS-READ-POINT (CH &AUX CH1 CH2 CH3 CH4)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (COND ((BIT-TEST CH #o20)
         (SETQ GRAPHICS-XPOS (14-BIT-SIGN-EXTEND (+ (SETQ CH1 (GRAPHICS-NETI))
                                                    (LSH (SETQ CH2 (GRAPHICS-NETI)) 7))))
         (SETQ GRAPHICS-YPOS (14-BIT-SIGN-EXTEND (+ (SETQ CH3 (GRAPHICS-NETI))
                                                    (LSH (SETQ CH4 (GRAPHICS-NETI)) 7)))))
        (T
         (INCF GRAPHICS-XPOS (SETQ CH1 (7-BIT-SIGN-EXTEND (GRAPHICS-NETI))))
         (INCF GRAPHICS-YPOS (SETQ CH2 (7-BIT-SIGN-EXTEND (GRAPHICS-NETI)))))))

(DEFUN 7-BIT-SIGN-EXTEND (NUMBER)
  (COND ((BIT-TEST NUMBER #o100)
         (- NUMBER #o200))
        (T NUMBER)))

(DEFUN 14-BIT-SIGN-EXTEND (NUMBER)
  (COND ((BIT-TEST NUMBER #o20000)
         (- NUMBER #o40000))
        (T NUMBER)))

(DEFUN GRAPHICS-ALU (CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (COND (GRAPHICS-XOR-MODE TV:ALU-XOR)
        ((BIT-TEST CH #o40) TV:ALU-ANDCA)
        (T TV:ALU-IOR)))

(DEFUN GRAPHICS-X-COORD (COORD)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (AND GRAPHICS-VIRTUAL-MODE
       (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE))))
  (+ GRAPHICS-X-OFFSET (MIN GRAPHICS-RIGHT (MAX GRAPHICS-LEFT COORD))))

(DEFUN GRAPHICS-Y-COORD (COORD)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (AND GRAPHICS-VIRTUAL-MODE
       (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE))))
  (- GRAPHICS-Y-OFFSET (MIN GRAPHICS-TOP (MAX GRAPHICS-BOTTOM COORD))))

(DEFUN GRAPHICS-Y-IN-RANGE (&AUX COORD)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (SETQ COORD GRAPHICS-YPOS)
  (AND GRAPHICS-VIRTUAL-MODE
       (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE))))
  ( GRAPHICS-BOTTOM COORD GRAPHICS-TOP))

;;;; Graphics commands.

(DEFUN GRAPHICS-NOTHING (IGNORE IGNORE)
  NIL)

(DEFUN GRAPHICS-XOR (IGNORE IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (SETQ GRAPHICS-XOR-MODE T))

(DEFUN GRAPHICS-IOR (IGNORE IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (SETQ GRAPHICS-XOR-MODE NIL))

(DEFUN GRAPHICS-VIRTUAL (IGNORE IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (SETQ GRAPHICS-VIRTUAL-MODE T))

(DEFUN GRAPHICS-PHYSICAL (IGNORE IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (SETQ GRAPHICS-VIRTUAL-MODE NIL))

(DEFUN GRAPHICS-MOVE (IGNORE CH)
  (GRAPHICS-READ-POINT CH))

(DEFUN GRAPHICS-PUSH (WINDOW IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (LET-GLOBALLY                                 ;use to be LET before fast flavors.
    ((GRAPHICS-XPOS GRAPHICS-XPOS)
     (GRAPHICS-YPOS GRAPHICS-YPOS)
     (GRAPHICS-RIGHT GRAPHICS-RIGHT)
     (GRAPHICS-LEFT GRAPHICS-LEFT)
     (GRAPHICS-TOP GRAPHICS-TOP)
     (GRAPHICS-BOTTOM GRAPHICS-BOTTOM)
     (GRAPHICS-XOR-MODE GRAPHICS-XOR-MODE)
     (GRAPHICS-VIRTUAL-MODE GRAPHICS-VIRTUAL-MODE))
    (DO (CH) (())
      (SETQ CH (GRAPHICS-NETI))
      (COND ((BIT-TEST CH #o100)
             (FUNCALL (OR (AREF DRAW-DISPATCH (LOGAND CH #o17))
                          'GRAPHICS-NOTHING)
                      WINDOW CH))
            (T
             (FUNCALL (OR (AREF GRAPHICS-DISPATCH CH)
                          'GRAPHICS-NOTHING)
                      WINDOW CH))))))

(DEFUN GRAPHICS-LIMIT (IGNORE CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (GRAPHICS-READ-POINT CH)
  (LET ((OXPOS GRAPHICS-XPOS) (OYPOS GRAPHICS-YPOS))
    (GRAPHICS-READ-POINT CH)
    (SETQ GRAPHICS-LEFT (MIN GRAPHICS-XPOS OXPOS)
          GRAPHICS-RIGHT (MAX GRAPHICS-XPOS OXPOS)
          GRAPHICS-BOTTOM (MIN GRAPHICS-YPOS OYPOS)
          GRAPHICS-TOP (MAX GRAPHICS-YPOS OYPOS))))


;;;; Drawing commands.

(DEFUN GRAPHICS-DRAW-LINE (WINDOW CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (LET ((OXPOS GRAPHICS-XPOS)
          (OYPOS GRAPHICS-YPOS))
      (GRAPHICS-READ-POINT CH)
      (SYSTEM:%DRAW-LINE (GRAPHICS-X-COORD OXPOS) (GRAPHICS-Y-COORD OYPOS)
                         (GRAPHICS-X-COORD GRAPHICS-XPOS)
                         (GRAPHICS-Y-COORD GRAPHICS-YPOS)
                         (GRAPHICS-ALU CH)
                         T
                         WINDOW))))

(DEFUN GRAPHICS-DRAW-POINT (WINDOW CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (GRAPHICS-READ-POINT CH)
    (SYSTEM:%DRAW-LINE (GRAPHICS-X-COORD GRAPHICS-XPOS)
                       (GRAPHICS-Y-COORD GRAPHICS-YPOS)
                       (GRAPHICS-X-COORD GRAPHICS-XPOS)
                       (GRAPHICS-Y-COORD GRAPHICS-YPOS)
                       (GRAPHICS-ALU CH)
                       T
                       WINDOW)))

(DEFUN GRAPHICS-DRAW-RECT (WINDOW CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (LET ((OXPOS GRAPHICS-XPOS)
          (OYPOS GRAPHICS-YPOS))
      (GRAPHICS-READ-POINT CH)
      (TV:%DRAW-RECTANGLE
        (ABS (1+ (- (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-X-COORD OXPOS))))
        (ABS (1+ (- (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-Y-COORD OYPOS))))
        (MIN (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-X-COORD OXPOS))
        (MIN (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-Y-COORD OYPOS))
        (GRAPHICS-ALU CH)
        WINDOW))))

(DEFUN GRAPHICS-ERASE-SCREEN (WINDOW IGNORE)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (TV:%DRAW-RECTANGLE
      (1+ (- (GRAPHICS-X-COORD GRAPHICS-RIGHT) (GRAPHICS-X-COORD GRAPHICS-LEFT)))
      (1+ (- (GRAPHICS-Y-COORD GRAPHICS-BOTTOM) (GRAPHICS-Y-COORD GRAPHICS-TOP)))
      (GRAPHICS-X-COORD GRAPHICS-LEFT)
      (GRAPHICS-Y-COORD GRAPHICS-TOP)
      (TV:SHEET-ERASE-ALUF WINDOW)
      WINDOW)))

(DEFUN GRAPHICS-DRAW-STRING (WINDOW CH)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (LET ((STRING (MAKE-STRING #o100 :FILL-POINTER 0)))
    (DO-FOREVER
      (LET ((CH (GRAPHICS-NETI)))
        (AND (ZEROP CH) (RETURN))
        (ARRAY-PUSH-EXTEND STRING CH)))
    (SEND WINDOW ':STRING-OUT-EXPLICIT STRING
          (GRAPHICS-X-COORD GRAPHICS-XPOS)
          (GRAPHICS-Y-COORD GRAPHICS-YPOS)
          (GRAPHICS-X-COORD GRAPHICS-RIGHT)
          NIL
          (TV:SHEET-CURRENT-FONT WINDOW)
          (GRAPHICS-ALU CH))
    (RETURN-ARRAY STRING)))

(DEFUN GRAPHICS-DRAW-BITS (WINDOW CH &AUX BIT-CHANGE-FUNCTION)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (SETQ BIT-CHANGE-FUNCTION (GRAPHICS-ALU CH))
    (DO ((I 1 (1+ I))) (())
      (LET ((NBITS (COND ((ZEROP (\ I 3)) 4) (T 6)))
            (X (GRAPHICS-X-COORD GRAPHICS-XPOS))
            (Y (GRAPHICS-Y-COORD GRAPHICS-YPOS))
            (CH (GRAPHICS-NETI)))
        (AND (BIT-TEST CH #o100) (RETURN))
        (AND (GRAPHICS-Y-IN-RANGE)
             (DOTIMES (BIT NBITS)
               (OR ( GRAPHICS-XPOS GRAPHICS-RIGHT)
                   (AND (BIT-TEST (LSH 1 (- NBITS 1 BIT)) CH)
                        (SETF (AR-2-REVERSE TV:SCREEN-ARRAY (+ BIT X) Y)
                              (BOOLE BIT-CHANGE-FUNCTION
                                     (AR-2-REVERSE TV:SCREEN-ARRAY (+ BIT X) Y)
                                     1))))))
        (INCF GRAPHICS-XPOS NBITS)))))

(DEFUN GRAPHICS-DRAW-RUNS (WINDOW CH &AUX BIT-CHANGE-FUNCTION)
  (DECLARE (:SELF-FLAVOR GRAPHICS-MIXIN))
  (TV:PREPARE-SHEET (WINDOW)
    (SETQ BIT-CHANGE-FUNCTION (GRAPHICS-ALU CH))
    (DO-FOREVER
      (LET ((CH (GRAPHICS-NETI))
            (OLDX (GRAPHICS-X-COORD GRAPHICS-XPOS))
            (Y (GRAPHICS-Y-COORD GRAPHICS-YPOS)))
        (AND (ZEROP CH) (RETURN))
        (INCF GRAPHICS-XPOS (LOGAND CH #o77))
        (AND (BIT-TEST CH #o100)
             (GRAPHICS-Y-IN-RANGE)
             (SYSTEM:%DRAW-LINE OLDX Y (MAX OLDX (1- (GRAPHICS-X-COORD GRAPHICS-XPOS))) Y
                                BIT-CHANGE-FUNCTION T WINDOW))))))

(DEFRESOURCE TYPEOUT-PROCESSES ()
  "Typeout processes for NVTs"
  :CONSTRUCTOR (MAKE-PROCESS "NVT-Typeout" ':SPECIAL-PDL-SIZE 2000.))

(DEFVAR *SUPDUP-WINDOWS* NIL)
(DEFVAR *SUPDUP-DEFAULT-PATH* NIL
  "NIL => use associated machine.")
(DEFVAR *SUPDUP-MODE* T
  "NIL => New window default")

(DEFVAR SUPDUP-WINDOWS)
(DEFVAR SUPDUP-DEFAULT-PATH)
(DEFVAR SUPDUP-MODE)
(FORWARD-VALUE-CELL 'SUPDUP-WINDOWS '*SUPDUP-WINDOWS*)
(FORWARD-VALUE-CELL 'SUPDUP-DEFAULT-PATH '*SUPDUP-DEFAULT-PATH*)
(FORWARD-VALUE-CELL 'SUPDUP-MODE '*SUPDUP-MODE*)

(DEFVAR JOURNAL-STREAM NIL
  "Stream for reccording history of events for debugging.")

(DEFUN FIND-SELECTABLE-SUPDUP (CONNECTED-P &OPTIONAL (SUP TV:MOUSE-SHEET))
  (DOLIST (W SUPDUP-WINDOWS)
    (AND (EQ (SEND W ':CONNECTED-P) CONNECTED-P)
         (OR (NULL SUP) (EQ SUP (TV:SHEET-SUPERIOR W)))
         (RETURN W))))

(DEFUN SUPDUP (&OPTIONAL PATH (MODE SUPDUP-MODE))
  "Make a SUPDUP connection to machine specified by PATH.
PATH is a machine name or a string saying how to get to one, such as
<arpanet-gateway><host> or <host>//<contact-name or socket number>
or <gateway><host>//<socket-number>.
If MODE is NIL, SUPDUP runs in (a window substituting for) this window.
Otherwise a separate SUPDUP window is selected."
  (IF MODE
      (SUPDUP-SEPARATE PATH)
      (SUPDUP-BIND PATH)))

(DEFVAR SUPDUP-FLAVOR 'SUPDUP)

(DEFUN SUPDUP-SEPARATE (&OPTIONAL PATH &AUX SW)
  "Switch to a non-connected SUPDUP window and connect it to machine PATH.
If PATH is NIL, a connected SUPDUP window will be selected if there is one."
  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-SUPDUP T NIL)))
         (SEND SW ':SELECT)
         NIL)
        (T
         (SETQ SW (OR (FIND-SELECTABLE-SUPDUP NIL) (TV:MAKE-WINDOW SUPDUP-FLAVOR)))
         (SEND SW ':SET-CONNECT-TO (OR PATH *SUPDUP-DEFAULT-PATH* SI:ASSOCIATED-MACHINE))
         (SEND SW ':EXPOSE NIL ':CLEAN)         ;Don't come up with old garbage
         (SEND SW ':SELECT)
         T)))

(TV:DEFWINDOW-RESOURCE SUPDUP-WINDOWS ()
  :INITIAL-COPIES 0
  :MAKE-WINDOW (SUPDUP :TYPEIN-PROCESS NIL :TYPEOUT-PROCESS NIL))

(DEFMETHOD (SUPDUP :SETUP) (WINDOW IN-P OUT-P)
  (LEXPR-SEND SELF ':SET-EDGES (MULTIPLE-VALUE-LIST (SEND WINDOW ':EDGES)))
  (SETQ ALIAS-WINDOW WINDOW)
  (SETQ TYPEOUT-PROCESS OUT-P
        TYPEIN-PROCESS IN-P)
  (PROCESS-PRESET TYPEOUT-PROCESS SELF ':TYPEOUT-TOP-LEVEL))

(DEFUN SUPDUP-BIND (&OPTIONAL (PATH SI:ASSOCIATED-MACHINE)
                    (WINDOW (SEND TERMINAL-IO ':ALIAS-FOR-SELECTED-WINDOWS)))
  "Enter SUPDUP connection to machine specified by PATH, /"in/" this window.
The I//O is done in a window that overlies the one that is TERMINAL-IO.
Network Q exits SUPDUP and returns from this function."
  (USING-RESOURCE (SUPDUP-WINDOW SUPDUP-WINDOWS)
    (USING-RESOURCE (TP TYPEOUT-PROCESSES)
      (SEND SUPDUP-WINDOW ':SETUP WINDOW CURRENT-PROCESS TP)
      (TV:WITH-SELECTION-SUBSTITUTE (SUPDUP-WINDOW WINDOW)
        (SEND SUPDUP-WINDOW ':CONNECT PATH)
        (CATCH-ERROR-RESTART ((SYS:ABORT ERROR) "Exit SUPDUP.")
          (SEND SUPDUP-WINDOW ':TYPEIN-TOP-LEVEL NIL))
;       (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
        T))))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :INIT) (INIT-PLIST)
  (SETQ TV:LABEL "FOO")
  (PUTPROP INIT-PLIST NIL ':MORE-P))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :SELECT) (&REST IGNORE)
  ;Move ourselves to the head of the list
  (WITHOUT-INTERRUPTS
    (SETQ SUPDUP-WINDOWS (DELQ SELF SUPDUP-WINDOWS))
    (PUSH SELF SUPDUP-WINDOWS)))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :DEACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS (SETQ SUPDUP-WINDOWS (DELQ SELF SUPDUP-WINDOWS))))

(DEFMETHOD (BASIC-SUPDUP :AFTER :ACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS
    (OR (MEMQ SELF SUPDUP-WINDOWS)
        (IF SUPDUP-WINDOWS
            (RPLACD (LAST SUPDUP-WINDOWS) (NCONS SELF))
          (SETQ SUPDUP-WINDOWS (NCONS SELF))))))

(DEFMETHOD (BASIC-SUPDUP :VERIFY-NEW-EDGES) (NEW-LEFT NEW-TOP NEW-WIDTH NEW-HEIGHT)
  NEW-LEFT NEW-TOP                              ;Unused
  (AND CONNECTION
       (OR ( NEW-WIDTH TV:WIDTH) ( NEW-HEIGHT TV:HEIGHT))
       "Attempt to change size while connected"))

;;; If more processing is turned on, a disaster results!
;;; The output process gets stuck and you can't type input at it to unhang it.
(DEFMETHOD (BASIC-SUPDUP :SET-MORE-P) (IGNORE)
  NIL)

(DEFMETHOD (BASIC-SUPDUP :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3))
  (MULTIPLE-VALUE-BIND (HOST GATEWAY CONTACT CONTACT-P)
      (PARSE-PATH PATH "SUPDUP" 137)
    ;; If the host runs the WAITS operating system, it will require char i/d.
    (LET ((SUPDUP-%TOCID (COND ((TYPEP HOST 'SI:HOST) (MEMQ (SEND HOST ':SYSTEM-TYPE)
                                                            '(:MULTICS :WAITS)))
                               ((STRINGP HOST)          ;No host name server.  flush this when
                                (MEM 'EQUALP HOST '("SAIL" "S1-A")))  ;above thing wins.
                               (T SUPDUP-%TOCID))))
      (SEND SELF ':NEW-CONNECTION HOST GATEWAY CONTACT CONTACT-P NET-WINDOW))))

(DEFMETHOD (BASIC-SUPDUP :GOBBLE-GREETING) ()
  (SEND-TTY-VARIABLES STREAM SELF NIL OVERPRINT)
  (SEND-FINGER-STRING STREAM)
  ;;Print out the greeting message ITS sends in ASCII.
  (DO ((CH #/CR (SEND STREAM ':TYI)))
      ((OR (NULL CH) (= CH 210)))       ;The end is marked with a %TDNOP, NIL is eof
    (AND (< CH #o40) (SETQ CH (+ #o200 CH)))
    (OR (= CH #o212)                    ;Don't type linefeeds (ITS sends CRLFs).
        (TYO CH SELF))))

;;; Send the initial information describing the Lisp Machine as an
;;; intelligent terminal.  The TTYOPT word contains the following:
;;; %TOERS+%TOMVB+%TOSAI+%TOOVR+%TOMVU+%TOLWR+%TOFCI+%TOMOR+%TOLID,,%TPCBS+%TPORS+%TPRSC
;;; Furthermore, if SUPDUP-%TOCID is non-NIL, then %TOCID will be on as well.
;;; It is off by default, because the Lispm is so fast at outputting characters
;;; that EMACS is effectively faster for the user without CID capability.
;;; SUPDUPing to SAIL and using SUPDUP-OUTPUT are kludged to bind this to T.
(DEFVAR SUPDUP-%TOCID NIL)

(DEFUN SEND-TTY-VARIABLES (STREAM SHEET LOCAL-EDIT-FLAG OVERPRINT)
    (18BIT-OUT STREAM -6)               ;First word LH has minus the count of following wds.
    (18BIT-OUT STREAM 0)
    (18BIT-OUT STREAM 0)                ;TCTYP word must be %TNSFW: 0,,7
    (18BIT-OUT STREAM 7)
    (18BIT-OUT STREAM
               (+ #o54632
                  (IF OVERPRINT #o1000 0)
                  (IF SUPDUP-%TOCID 1 0)))      ;TTYOPT word explained above.
    (18BIT-OUT STREAM #o54)
    (18BIT-OUT STREAM 0)                ;TCMXV
    (18BIT-OUT STREAM (1- (TRUNCATE (TV:SHEET-INSIDE-HEIGHT SHEET)
                                    (TV:SHEET-LINE-HEIGHT SHEET))))
    (18BIT-OUT STREAM 0)                ;TCMXH
    (18BIT-OUT STREAM (1- (TRUNCATE (TV:SHEET-INSIDE-WIDTH SHEET)
                                    (TV:SHEET-CHAR-WIDTH SHEET))))
    (18BIT-OUT STREAM 0)                ;TTYROL
    (18BIT-OUT STREAM 0)                ;No scrolling
    (18BIT-OUT STREAM (+ (LSH (TV:SHEET-LINE-HEIGHT SHEET) 10.) ;TTYSMT
                         (LSH (TV:SHEET-CHAR-WIDTH SHEET) 6)
                         #o55))
    (18BIT-OUT STREAM (+ #o040000 (IF LOCAL-EDIT-FLAG (+ #o100000
;Don't turn on line-saving.  It slows TECO a lot to think about it. - RMS
                                                       0 ;(LSH 5 11.)
                                                       ) 0)))
    (SEND STREAM ':FORCE-OUTPUT))

(DEFUN 18BIT-OUT (STREAM N)
    (SEND STREAM ':TYO (LDB #o1406 N))
    (SEND STREAM ':TYO (LDB #o0606 N))
    (SEND STREAM ':TYO (LDB #o0006 N)))

;;;Send the string to TELSER saying where we are, so that NAME can find it inside
;;;the TELSER and print it.  Boy, what a kludge.
(DEFUN SEND-FINGER-STRING (STREAM)
  (SEND STREAM ':TYO #o300)                     ;SUPDUP escape string meaning that the FINGER
  (SEND STREAM ':TYO #o302)                     ;identification string follows.
  (SEND STREAM ':STRING-OUT SI:LOCAL-FINGER-LOCATION)
  (SEND STREAM ':TYO 0)                         ; End with a 0.
  (SEND STREAM ':FORCE-OUTPUT))

(DEFMETHOD (BASIC-SUPDUP :AFTER :DISCONNECT) ()
  (SEND SELF ':SET-LABEL (FORMAT NIL "~A -- not connected" TV:NAME)))

(DEFVAR SUPDUP-KEYS (MAKE-ARRAY #o201 ':TYPE 'ART-16B))
(FILLARRAY SUPDUP-KEYS '(4177                   ;integral
                         0    4102 4103 32      ;null, break, clear, call
                         4101 37   4110 177     ;esc, backnext, help, rubout
                         10   11   12   13      ;bs, tab, lf, vt
                         14   15   4102 323     ;form, cr, quote, hold-output
                         37   4103 310  0       ;stop-output, abort, resume, status
                         233  0    0    0    0  ;end, I, II, III, IV
                         0    0    0    0    0  ;up, down, left, right, system, network
                         4102))                 ;system

(DEFMETHOD (BASIC-SUPDUP :NET-OUTPUT-TRANSLATED) (CH)
  (UNLESS (CONSP CH)
    (LET ((CHAR (CHAR-CODE CH)))
      (SEND SELF ':NET-OUTPUT (LOGIOR (LSH (CHAR-BITS CH) 7)
                                      (COND ((= CHAR #o33) CHAR)        ;(Special case)
                                            ((< CHAR #o40) (LOGIOR CHAR #o4000))
                                            ((< CHAR #o177) CHAR)
                                            (T (AREF SUPDUP-KEYS (- CHAR #o177)))))))))

;;; This sends a character of the ITS 12-bit character set to the network,
;;; using the ITS Intelligent Terminal Protocol to get the extra bits through.
(DEFMETHOD (BASIC-SUPDUP :NET-OUTPUT) (CH &AUX BITS)
  (SETQ BITS (LDB #o0705 CH))
  (COND ((NOT (ZEROP BITS))
         (LOCK-OUTPUT
           (SEND STREAM ':TYO #o34)
           (SEND STREAM ':TYO (LOGIOR #o100 BITS))
           (SEND STREAM ':TYO (LOGAND #o177 CH))))
        ((= CH #o34)
         (LOCK-OUTPUT
           (SEND STREAM ':TYO #o34)
           (SEND STREAM ':TYO CH)))
        (T (LOCK-OUTPUT (SEND STREAM ':TYO CH)))))

(DEFMETHOD (BASIC-SUPDUP :LOGOUT) ()
  (LOCK-OUTPUT
    (SEND STREAM ':TYO 300)
    (SEND STREAM ':TYO 301)
    (SEND STREAM ':FINISH)))

;;; Dispatch table for the %TD codes.
(DEFVAR SUPDUP-%TD-DISPATCH (MAKE-ARRAY 40))
(FILLARRAY SUPDUP-%TD-DISPATCH
   '(SUPDUP-TDMOV SUPDUP-TDMV0 TV:SHEET-CLEAR-EOF TV:SHEET-CLEAR-EOL TV:SHEET-CLEAR-CHAR
;;;  %TDMOV       %TDMV0       %TDEOF             %TDEOL             %TDDLF

     SUPDUP-NOTHING SUPDUP-GT40 TV:SHEET-CRLF SUPDUP-NOTHING SUPDUP-TDBS SUPDUP-TDLF
;;;  %TDMTF         %TDMTN      %TDCRL        %TDNOP         %TDBS          %TDLF

     SUPDUP-TDCR SUPDUP-TDORS SUPDUP-TDQOT TV:SHEET-SPACE SUPDUP-TDMV0 SUPDUP-CLEAR
;;;  %TDCR          %TDORS       %TDQOT       %TDFS    %TDMV0       %TDCLR

     SUPDUP-BEEP    SUPDUP-NOTHING SUPDUP-INSERT-LINE SUPDUP-DELETE-LINE
;;;  %TDBEL         %TDINI         %TDILP             %TDDLP

     SUPDUP-INSERT-CHAR SUPDUP-DELETE-CHAR SUPDUP-TDBOW SUPDUP-RESET SUPDUP-GRAPHICS
;;;  %TDICP             %TDDCP             %TDBOW         %TDRST         %TDGRF
     SUPDUP-REGION-UP SUPDUP-REGION-DOWN
;;;  %TDRSU             %TDRSD

;;; PTV compatibility hacks (ARDS, etc.)
     SUPDUP-NOTHING SUPDUP-ARDS-SET
;;;  %TDGXT         %TDLNG

     SUPDUP-ARDS-LONG   SUPDUP-ARDS-SHORT
;;;  %TDLV              %TDSV
     ))

(DEFMETHOD (BASIC-SUPDUP :BUFFERED-TYO) SUPDUP-BUFFERED-TYO)

(DEFUN SUPDUP-BUFFERED-TYO (IGNORE CH)
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (COND ((< CH 200)
         (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
           (SEND SELF ':FORCE-OUTPUT)))
        (T
         (SEND SELF ':FORCE-OUTPUT)
         (OR (>= (SETQ CH (- CH 200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
             (SEND (AREF SUPDUP-%TD-DISPATCH CH) SELF)))))

;;;Handle %TDMOV by ignoring two characters and then acting as if it were a %TDMV0.
(DEFUN SUPDUP-TDMOV (SHEET)
  (NVT-NETI)
  (NVT-NETI)
  (SUPDUP-TDMV0 SHEET))

;;;Handle %TDMV0 or %TDMV1 by moving the cursor.  This is kludgey because
;;;ITS sends out positions as VPOS followed by HPOS.
(DEFUN SUPDUP-TDMV0 (SHEET &AUX YPOS)
  (DECLARE (:SELF-FLAVOR TV:WINDOW))
  (SETQ YPOS (* (NVT-NETI) TV:LINE-HEIGHT))
  (TV:SHEET-SET-CURSORPOS SHEET
                          (* (NVT-NETI) TV:CHAR-WIDTH)
                          YPOS))

(DEFUN SUPDUP-TDBS (SHEET)
  (SEND SHEET ':BACKWARD-CHAR))

(DEFUN SUPDUP-TDCR (SHEET)
  (TV:SHEET-SET-CURSORPOS SHEET 0 (NTH-VALUE 1 (TV:SHEET-READ-CURSORPOS SHEET))))

(DEFUN SUPDUP-TDLF (SHEET)
  (DECLARE (:SELF-FLAVOR TV:WINDOW))
  (SEND SHEET ':INCREMENT-CURSORPOS 0 TV:LINE-HEIGHT))

;;; This "null function" is used for codes which we should ignore.
(DEFUN SUPDUP-NOTHING (IGNORE) NIL)

;;; Handle %TDORS.  Just tell ITS where the cursor position is, using the
;;; Intelligent Terminal Protocol's ^\ ^P command.
(DEFUN SUPDUP-TDORS (SHEET &AUX VPOS HPOS)
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (MULTIPLE-VALUE (HPOS VPOS)
    (TV:SHEET-READ-CURSORPOS SHEET))
  (LOCK-OUTPUT
    (SEND STREAM ':TYO #o34)                    ;^\
    (SEND STREAM ':TYO #o20)                    ;^P
    (SEND STREAM ':TYO (TRUNCATE VPOS TV:LINE-HEIGHT))
    (SEND STREAM ':TYO (TRUNCATE HPOS TV:CHAR-WIDTH))
    (SEND STREAM ':FORCE-OUTPUT)))

;;; %TDQOT means the next character should be quoted.
(DEFUN SUPDUP-TDQOT (SHEET)
  (TV:SHEET-TYO SHEET (NVT-NETI)))

;;; %TDBEL means to ring the "bell".
;;; To avoid gross obnoxosity, we merge multiple consecutive beeps into one
(DEFUN SUPDUP-BEEP (IGNORE)
  (DECLARE (:SELF-FLAVOR BASIC-NVT))
  (SEND SELF ':REMOTE-BEEP)
  (DO ((CH (SEND STREAM ':TYI-NO-HANG) (SEND STREAM ':TYI-NO-HANG)))
      ((OR (NULL CH) ( CH #o221))
       (AND CH (SEND STREAM ':UNTYI CH)))))


;;; Display list array.
(DEFVAR GT40-DISPLAY-LIST (MAKE-ARRAY 10. ':TYPE 'ART-Q-LIST))
(DEFVAR GT40-BLINKER NIL)
(DEFVAR GT40-CURRENT-ITEM-NUMBER)
(DEFVAR SUDS-KBD-NEW-TABLE                      ;allows thumb keys to be used
  (LET ((TBL (SI:KBD-MAKE-NEW-TABLE)))
    (DOLIST (L '((#o176 #// #/ #// #/) (#o106 #/\ #/| #/\ #/|)
                 (#o117 #/[ #/{ #/[ #/{) (#o17 #/] #/} #/] #/})))
      (LET ((NCH (FIRST L)) (LCH (REST1 L)))
        (DOTIMES (I 5)
          (ASET (CAR LCH) TBL I NCH)
          (IF (REST1 LCH) (SETQ LCH (REST1 LCH))))))
    TBL))

;;; %TDCLR
(DEFUN SUPDUP-CLEAR (SHEET)
  (TV:SHEET-CLEAR SHEET)
  (FILLARRAY GT40-DISPLAY-LIST '(NIL)))

;;; %TDILP means to insert lines, takes one arg from stream which is number of lines to insert
;;; Lines are inserted at current VPOS.  The current line is affected.
(DEFUN SUPDUP-INSERT-LINE (SHEET)
  (TV:SHEET-INSERT-LINE SHEET (NVT-NETI)))

;;; %TDDLP means to delete lines, takes one arg from stream which is the number of lines.
;;; Affects the current line.
(DEFUN SUPDUP-DELETE-LINE (SHEET)
  (TV:SHEET-DELETE-LINE SHEET (NVT-NETI)))

;;; %TDRSU, %TDRSD followed by height, n-lines
(DEFUN SUPDUP-REGION-UP (SHEET &OPTIONAL
                         (REGION-HEIGHT (NVT-NETI))
                         (SCROLL-AMOUNT (NVT-NETI)))
  (TV:PREPARE-SHEET (SHEET)
    (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
          (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
          (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
          REGION-BOTTOM
          DELTA-HEIGHT)
      (SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
            REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
                               (* LINE-HEIGHT
                                  (TRUNCATE (TV:SHEET-INSIDE-BOTTOM SHEET)
                                            LINE-HEIGHT)))
            REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
            SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
      ;; Get size of region to BLT up
      (SETQ DELTA-HEIGHT (- REGION-HEIGHT SCROLL-AMOUNT))
      (OR (<= DELTA-HEIGHT 0)                   ;If some bits to move, move them
          (BITBLT TV:ALU-SETA
                  WIDTH DELTA-HEIGHT
                  ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
                  (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)
                  ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)))
      (TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
                          (TV:SHEET-INSIDE-LEFT SHEET)
                          (- REGION-BOTTOM SCROLL-AMOUNT)
                          (TV:SHEET-ERASE-ALUF SHEET) SHEET))))

(DEFUN SUPDUP-REGION-DOWN (SHEET &OPTIONAL
                           (REGION-HEIGHT (NVT-NETI))
                           (SCROLL-AMOUNT (NVT-NETI)))
  (TV:PREPARE-SHEET (SHEET)
    (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
          (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
          (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
          REGION-BOTTOM
          DELTA-HEIGHT)
      (SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
            REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
                               (* LINE-HEIGHT
                                  (TRUNCATE (TV:SHEET-INSIDE-BOTTOM SHEET)
                                            LINE-HEIGHT)))
            REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
            SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
      ;; Get negative size of region to BLT down
      (SETQ DELTA-HEIGHT (- SCROLL-AMOUNT REGION-HEIGHT))
      (OR ( DELTA-HEIGHT 0)                    ;If some bits to move, move them
          (BITBLT TV:ALU-SETA
                  WIDTH DELTA-HEIGHT
                  ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
                  ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
                  (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)))
      (TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
                          (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
                          (TV:SHEET-ERASE-ALUF SHEET) SHEET))))

;;; %TDICP insert character positions, takes an arg.
(DEFUN SUPDUP-INSERT-CHAR (SHEET)
  (TV:SHEET-INSERT-CHAR SHEET (NVT-NETI)))

;;; %TDDCP delete character positions, takes an arg.
(DEFUN SUPDUP-DELETE-CHAR (SHEET)
  (TV:SHEET-DELETE-CHAR SHEET (NVT-NETI)))

(DEFUN SUPDUP-TDBOW (SHEET)
  (SEND SHEET ':SET-BLACK-ON-WHITE T))

(DEFUN SUPDUP-RESET (SHEET)
  (SEND SHEET ':SET-BLACK-ON-WHITE NIL)
  (GRAPHICS-RESET SHEET))

;;;; GT40 Simulator (used with the DEC simulator on I.T.S. for running SUDS)

;;; This crock maintains a display list for writing, erasing, and moving display objects
;;; consisting of characters, vectors, and points.  This protocol is not documented
;;; anywhere except in the code for DECUUO.

;; Dispatch table for the GT40 simulator.  These functions take one argument, the pc-ppr.
(DEFVAR GT40-DISPATCH (MAKE-ARRAY 17))
(FILLARRAY GT40-DISPATCH
           '(GT40-INSERT-OR-DELETE
             GT40-INSERT
             GT40-DELETE
;            GT40-RESET
;            GT40-TURN-ON
;            GT40-TURN-OFF
;            GT40-COPY
;            GT40-MOVE
;            GT40-MODE
;            GT40-APPEND
;            GT40-SUBROUTINIZE
;            GT40-UNSUBROUTINIZE
             SUPDUP-NOTHING))                   ;most are not used by DECUUO

;;; %TDMTN is a crock for simulating GT-40's, used by DECUUO on ITS for Imlacs...

(DEFUN SUPDUP-GT40 (SHEET &AUX (BYTE (- (NVT-NETI) 100)))
  (IF ( (AREF SUDS-KBD-NEW-TABLE 0 #o176)      ;crock for thumb keys, only when
         (AREF SI:KBD-NEW-TABLE 0 #o176))               ;doing GT40 simulation
      (SETQ SI:KBD-NEW-TABLE SUDS-KBD-NEW-TABLE))
  (OR (< BYTE 0)
      (SEND (AREF GT40-DISPATCH (LOGAND 17 BYTE)) SHEET)))

;;; Macros used below to pack characters into words, decode vector formats, etc.

;;; Make a 16-bit "word" from 3 chars in 6-4-6 format
(DEFMACRO GT40-WORD ()
  '(DPB (NVT-NETI) #o0006
        (DPB (NVT-NETI) #o0604
             (DPB (NVT-NETI) #o1206 0))))

;;; Get a word count
(DEFMACRO GT40-COUNT () '(LSH (- (GT40-WORD) 5) -1))

;;; Used in constructing display objects - used only in GT40-INSERT.
(DEFMACRO APUSH (DOB ITEM) `(ARRAY-PUSH-EXTEND ,DOB ,ITEM 500.))

;;; Compute the index of the last thing pushed
(DEFMACRO GT40-LAST-INDEX (DOB) `(1- (ARRAY-ACTIVE-LENGTH ,DOB)))

;;; Get the last item pushed onto a display object
(DEFMACRO GT40-LAST-ITEM (DOB) `(AREF ,DOB (GT40-LAST-INDEX ,DOB)))

;;; Short vector format
(DEFMACRO GT40-SHORT (DOB WORD)
  `(PROGN
     (APUSH ,DOB (* (LDB 0706 ,WORD) (IF (BIT-TEST #o20000 ,WORD) -1 1)))
     (APUSH ,DOB (* (LDB 0006 ,WORD) (IF (BIT-TEST #o100 ,WORD) -1 1)))
     (APUSH ,DOB (BIT-TEST 40000 ,WORD))))

;;; Long vector format
(DEFMACRO GT40-LONG (DOB WORD1 WORD2)
   `(LET ((WORD2 ,WORD2))
      (APUSH ,DOB (* (LOGAND #o1777 ,WORD1) (IF (BIT-TEST #o20000 ,WORD1) -1 1)))
      (APUSH ,DOB (* (LOGAND #o1777 WORD2) (IF (BIT-TEST #o20000 WORD2) -1 1)))
      (APUSH ,DOB (BIT-TEST #o40000 ,WORD1))))

;;; Coordinate scaling macro
(DEFMACRO GT40-COORD (X) `(MAX 0 (TRUNCATE (* 7 ,X) 10.)))

;;; Draw a string.  Note special end of line hackery.  XPOS and YPOS must be symbols.
(DEFMACRO GT40-DRAW-STRING (STRING XPOS YPOS SHEET)
  `(LET ((MAX-Y 750.))
     (SEND ,SHEET ':STRING-OUT-EXPLICIT ,STRING
           (GT40-COORD ,XPOS) (- MAX-Y (GT40-COORD ,YPOS) 11.)
           (TV:SHEET-INSIDE-RIGHT ,SHEET) NIL
           (TV:SHEET-CURRENT-FONT ,SHEET)
           TV:ALU-XOR)))

;;; Draw a vector.  XPOS and YPOS must be symbols
(DEFMACRO GT40-DRAW-VECTOR (XPOS YPOS X Y FLAG SHEET)
  `(LET ((MAX-Y 750.) (OXPOS ,XPOS) (OYPOS ,YPOS))
     (SETQ ,XPOS (+ ,XPOS ,X) ,YPOS (+ ,YPOS ,Y))
     (IF ,FLAG
         (TV:PREPARE-SHEET (,SHEET)
           (TV:%DRAW-LINE (GT40-COORD OXPOS) (- MAX-Y (GT40-COORD OYPOS))
                          (GT40-COORD ,XPOS) (- MAX-Y (GT40-COORD ,YPOS))
                          TV:ALU-XOR NIL ,SHEET)))))

;;; Read a vector out of the display list and draw it
(DEFMACRO GT40-VECTOR (DOB XPOS YPOS SHEET)
  `(LET ((I (GT40-LAST-INDEX ,DOB)))
     (GT40-DRAW-VECTOR
      ,XPOS ,YPOS
      (AREF ,DOB (- I 2)) (AREF ,DOB (- I 1))   ;new x y
      (AREF ,DOB I) ,SHEET)))                   ;visibility flag

;;; Display list format:  The display list is an ART-Q array of display objects, each of
;;; which is, in turn, an ART-Q array.  The format of display objects is a sequence of
;;; display items.  A display item is either a single string of characters or an in-line
;;; subsequence consisting of a symbol describing the item-type followed by 2 numbers (x,y)
;;; and a visibility flag.  Numbers and flags are repeated until a new symbol is encountered
;;; indicating a type change.

;;; GT40 Command 0 - Insert or delete display items
(DEFUN GT40-INSERT-OR-DELETE (SHEET)
  (SELECTQ (LOGAND 3 (GT40-WORD))               ;only 1 and 2 are recognized for now
    (1 (GT40-INSERT SHEET))                     ;insert a new display item
    (2 (GT40-DELETE SHEET (1+ (GT40-COUNT)))))) ;delete n items

;;; GT40 Command 1 - Insert a display item into the display list.
(DEFUN GT40-INSERT (SHEET &AUX (WORD-COUNT (GT40-COUNT)))
  (GT40-DELETE SHEET 1 NIL)             ;Delete the item we are about to insert
  (DO ((I 0 (1+ I))                     ;Loop over words, contructing a display list
       (WORD)(MODE -1)                  ;Mode is initially undefined.
       (XPOS 0) (YPOS 0) (BLINK-THIS)
       (DOB                             ;Display OBject
        (OR (AREF GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER)   ;Already an array or
            (ASET (MAKE-ARRAY 200.
                              ':LEADER-LIST '(0 NIL)) ;cons an array with leader
                  GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER))))        ;and install it
      (( I WORD-COUNT)
       (IF (= 0 MODE)                   ; was char mode, display the string
           (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
       (IF BLINK-THIS (STORE-ARRAY-LEADER 'ON DOB 1)))
    (SETQ WORD (GT40-WORD))
    (COND ((BIT-TEST #o100000 WORD)     ;If command, only look at blink bit and mode
           (IF (NOT (BIT-TEST 40000 WORD))      ;ignore words with the 40000 bit on
               (LET ((NMODE (LDB 1303 WORD))
                     (BLINK-FLAG (AND (BIT-TEST 20 WORD) (BIT-TEST 10 WORD))))
                  (COND ((NOT (= MODE NMODE))   ;get the new datatype mode
                         (IF (= 0 MODE) ; was char mode, display the string
                             (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
                         (SETQ MODE NMODE)
                         (APUSH DOB (SELECTQ MODE       ;initializings
                                      (0 (MAKE-ARRAY 10.
                                                     ':TYPE 'ART-STRING
                                                     ':LEADER-LIST '(0)))
                                      (1 'VECTOR)
                                      (2 'VECTOR)
                                      (3 'POINT)
                                      (6 'RPOINT)
                                      ((4 5 7) 'UNKNOWN)))))
                  (COND (BLINK-FLAG
                         (OR (MEMQ GT40-BLINKER (TV:SHEET-BLINKER-LIST SHEET))
                             (SETQ GT40-BLINKER
                                   (TV:MAKE-BLINKER SHEET 'GT40-BLINKER)))
                         (SETQ BLINK-THIS T))))))
          (T (SELECTQ MODE
               (0 (DO ((CHAR (LDB #o0007 WORD) (LDB 1007 WORD)) ;character mode
                       (STRING (GT40-LAST-ITEM DOB))
                       (I 0 (1+ I)))
                      ((= I 2))
                      (OR (= 0 CHAR) (= 17 CHAR) (ARRAY-PUSH-EXTEND STRING CHAR))))
               (1 (GT40-SHORT DOB WORD) ;short vector
                  (GT40-VECTOR DOB XPOS YPOS SHEET))
               (2 (SETQ I (1+ I))       ;long vector
                  (GT40-LONG DOB WORD (GT40-WORD))
                  (GT40-VECTOR DOB XPOS YPOS SHEET))
               (3 (SETQ I (1+ I))       ;point data
                  (GT40-LONG DOB WORD (GT40-WORD))
                  (LET ((I (GT40-LAST-INDEX DOB)))
                       (SETQ XPOS (AREF DOB (- I 2))
                             YPOS (AREF DOB (- I 1)))
                       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
               (4)                      ;graphplot x data (not used)
               (5)                      ;graphplot y data (not used)
               (6 (GT40-SHORT DOB WORD) ;relative point data
                  (LET ((I (GT40-LAST-INDEX DOB)))
                       (SETQ XPOS (+ XPOS (AREF DOB (- I 2)))
                             YPOS (+ YPOS (AREF DOB (- I 1))))
                       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
               (7)))))                  ;not used
  (GT40-WORD))                          ;gobble the checksum

;;; GT40 Command 2 - Delete a display item from the display list
(DEFUN GT40-DELETE (SHEET &OPTIONAL (NITEMS 1) (CHECKSUM-FLAG T))
  (DO ((I 0 (1+ I)) (DOB) (ITEM-NUMBER))
      (( I NITEMS))
    (SETQ ITEM-NUMBER (GT40-WORD)
          GT40-CURRENT-ITEM-NUMBER ITEM-NUMBER  ;record item # being hacked
          DOB (AREF GT40-DISPLAY-LIST ITEM-NUMBER))
    (IF DOB (PROGN (OR (EQ 'OFF (ARRAY-LEADER DOB 1))   ;don't erase if its already off
                       (GT40-DISPLAY-ITEM DOB SHEET))
                   (FILLARRAY DOB '(NIL))
                   (STORE-ARRAY-LEADER 0 DOB 0) ;zero the fill pointer
                   (STORE-ARRAY-LEADER NIL DOB 1))))    ;blinking is off
  (IF CHECKSUM-FLAG (GT40-WORD)))               ;gobble the checksum

;;; Display a display item.
(DEFUN GT40-DISPLAY-ITEM (DOB SHEET)
  (DO ((I 0 (1+ I))
       (END (ARRAY-ACTIVE-LENGTH DOB))
       (ITEM) (X) (Y) (FLAG) (XPOS 0) (YPOS 0))
      ((>= I END))
    (SETQ ITEM (AREF DOB I))
    (COND ((STRINGP ITEM) (GT40-DRAW-STRING ITEM XPOS YPOS SHEET))
          ((EQ 'UNKNOWN ITEM))          ;ignore
          (T (DO NIL
                 ((OR (<= (- END I) 3)
                      (SYMBOLP (AREF DOB (1+ I)))
                      (STRINGP (AREF DOB (1+ I)))))
                 (SETQ I (+ 3 I)
                       X    (AREF DOB (- I 2))
                       Y    (AREF DOB (- I 1))
                       FLAG (AREF DOB I))
                 (SELECTQ ITEM
                   (VECTOR (GT40-DRAW-VECTOR XPOS YPOS X Y FLAG SHEET))
                   (POINT (SETQ XPOS X YPOS Y)
                          (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))
                   (RPOINT (SETQ XPOS (+ XPOS X) YPOS (+ YPOS Y))
                           (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))))))))

(DEFFLAVOR GT40-BLINKER () (TV:BLINKER))

;;; Blink a display item
(DEFMETHOD (GT40-BLINKER :BLINK) ()
  (LET-GLOBALLY ((TV:PHASE NIL))
    (DO ((ITEM (G-L-P GT40-DISPLAY-LIST) (CDR ITEM))
         (BLINK-FLAG NIL NIL)
         (DITEM))
        ((NULL ITEM))
      (SETQ DITEM (CAR ITEM))
      (IF DITEM (SETQ BLINK-FLAG (ARRAY-LEADER DITEM 1)))
      (IF (MEMQ BLINK-FLAG '(ON OFF))
          (PROGN (GT40-DISPLAY-ITEM DITEM TV:SHEET)
                 (STORE-ARRAY-LEADER (SELECTQ BLINK-FLAG (ON 'OFF) (OFF 'ON)) DITEM 1))))))

(DEFMETHOD (GT40-BLINKER :SIZE) ()
  (VALUES (TV:SHEET-INSIDE-WIDTH TV:SHEET) (TV:SHEET-INSIDE-HEIGHT TV:SHEET)))

;;;; ARDS simulator (for compatibility with PTV's)

;;; Todo: these variables should be instance variables
;;;       scaling and offset doesn't work right in this version...
;;;       SHOULD SEND LINE DRAWING MESSAGES RATHER THAN CALLING %DRAW-LINE

(DEFVAR ARDS-XPOS 0)                            ;current pos in ARDS coordinates
(DEFVAR ARDS-YPOS 0)
(DEFVAR ARDS-SCALE 1.0)
(DEFVAR ARDS-SCR-XPOS 0)                        ;current pos in screen coordinates
(DEFVAR ARDS-SCR-YPOS 0)

;;; Setup scaling and offsets, then loop until exit condition
(DEFMACRO ARDS-LOOP (&REST BODY)
  `(LET* ((ARDS-MAX-X (+ TV:X-OFFSET TV:WIDTH))
          (ARDS-MAX-Y (+ TV:Y-OFFSET TV:HEIGHT))
          (ARDS-X-OFFSET TV:X-OFFSET)
          (ARDS-Y-OFFSET TV:Y-OFFSET)
          (ARDS-SCR-SCALE (* ARDS-SCALE (// (MIN TV:WIDTH TV:HEIGHT) 1023.0)))
          (ARDS-CENTER-OFFSET (TRUNCATE (1+ (- (MAX TV:WIDTH TV:HEIGHT) (MIN TV:WIDTH TV:HEIGHT)))
                                        2))
          (ARDS-FLAG NIL))
     (IF (< TV:WIDTH TV:HEIGHT) (SETQ ARDS-MAX-Y (- ARDS-MAX-Y ARDS-CENTER-OFFSET))
         (SETQ ARDS-X-OFFSET (+ ARDS-X-OFFSET ARDS-CENTER-OFFSET)))
     (*CATCH 'ARDS-RETURN
             (DO NIL (NIL) ,@BODY))))

;;; Convert -512./511. to 0/1023. and scale if the user wants it.
(DEFMACRO ARDS-COORD (X)
  `(MAX 1 (FIX (+ .5 (* ARDS-SCR-SCALE (+ 512. ,X))))))

;;; Get a character and punt out of graphics mode if it is a control char or %TD code
(DEFMACRO ARDS-GET ()
  '(LET ((X (NVT-NETI)))
     (IF (OR (< X 100) (> X 177))
         (*THROW 'ARDS-RETURN
                 (PROGN (SEND STREAM ':UNTYI X)
                        (TV:SHEET-SET-CURSORPOS SHEET
                                                ARDS-SCR-XPOS
                                                (- ARDS-SCR-YPOS 11.)))))
     X))

;;; Unpack long and short format coordinates
(DEFMACRO ARDS-LONG (F)
  `(LET ((A (ARDS-GET)) (B (ARDS-GET)))
     ,(IF F '(SETQ ARDS-FLAG (NOT (BIT-TEST B 40))))
     (* (IF (BIT-TEST A 1) -1 1)
        (LOGIOR (LSH (LOGAND 77 A) -1) (LSH (LOGAND 37 B) 5)))))

(DEFMACRO ARDS-SHORT ()
  `(LET ((A (ARDS-GET)))
     (SETQ ARDS-FLAG T)
     (* (IF (BIT-TEST A 1) -1 1)
        (LSH (LOGAND 77 A) -1))))

;;; Draw a vector
(DEFMACRO ARDS-VECTOR (DX DY)
  `(LET ((X0 ARDS-XPOS) (Y0 ARDS-YPOS))
     (SETQ ARDS-XPOS (+ ARDS-XPOS ,DX)
           ARDS-YPOS (+ ARDS-YPOS ,DY)
           ARDS-SCR-XPOS (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD ARDS-XPOS)))
           ARDS-SCR-YPOS (MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD ARDS-YPOS))))
     (IF ARDS-FLAG
         (TV:PREPARE-SHEET (SHEET)
           (TV:%DRAW-LINE (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD X0)))
                          (MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD Y0)))
                          ARDS-SCR-XPOS
                          ARDS-SCR-YPOS
                          TV:ALU-IOR
                          T
                          SHEET)))))

(DEFUN SUPDUP-ARDS-SET (SHEET)
  (DECLARE (:SELF-FLAVOR BASIC-SUPDUP))
  (ARDS-LOOP
    (SETQ ARDS-XPOS (ARDS-LONG T) ARDS-YPOS (ARDS-LONG NIL))
    (ARDS-VECTOR 0 0)))         ;for plotting points

(DEFUN SUPDUP-ARDS-LONG (SHEET)
  (DECLARE (:SELF-FLAVOR BASIC-SUPDUP))
  (ARDS-LOOP (ARDS-VECTOR (ARDS-LONG T) (ARDS-LONG NIL))))

(DEFUN SUPDUP-ARDS-SHORT (SHEET)
  (DECLARE (:SELF-FLAVOR BASIC-SUPDUP))
  (ARDS-LOOP (ARDS-VECTOR (ARDS-SHORT) (ARDS-SHORT))))


;;; This is a sort of SUPDUP which records the current contents of the screen
;;; at all times in a vector of lines.  Each line is a string of fixed length
;;; whose unused chars at the end are all filled with #/RETURN.

;;; It is building block for the SUPDUP which does local editing operations.

;;; SCREEN-LINE-ARRAY is an array of strings, one per screen line.
;;; Each string is as long as the width of the terminal.
;;; It has a leader containing a fill pointer (always constant)
;;; and two other slots, which record whether the line begins
;;; or ends with a continuation.
(DEFSUBST SCREEN-LINE-BEG-CONTINUED (VPOS)
  (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY VPOS) 1))

(DEFSUBST SCREEN-LINE-END-CONTINUED (VPOS)
  (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY VPOS) 2))

(DEFFLAVOR RECORDING-SUPDUP (SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY
                             (CURRENT-XPOS 0) (CURRENT-YPOS 0)
                             HEIGHT-IN-LINES
                             (FIRST-COL-TO-SAVE 0)
                             LAST-COL-TO-SAVE+1
                             (LINE-LABEL-MAX 2000)
                             REDISPLAY-STRING
                             SAVED-LINE-ARRAY
                             (MULTI-POS-CHAR-BEG 0)
                             (MULTI-POS-CHAR-END 0)
                             (ALLOW-LOCAL-EDITING NIL))
           (SUPDUP))

(DEFMETHOD (RECORDING-SUPDUP :AFTER :CHANGE-OF-SIZE-OR-MARGINS)
           (&REST IGNORE)
  (SETQ HEIGHT-IN-LINES (1- (TRUNCATE (TV:SHEET-INSIDE-HEIGHT SELF) (TV:SHEET-LINE-HEIGHT SELF))))
  (LET ((WIDTH (TRUNCATE (TV:SHEET-INSIDE-WIDTH SELF) (TV:SHEET-CHAR-WIDTH SELF))))
    ;; Record one line which doesn't appear on the screen.
    ;; This is so that line saving can be used to save a line
    ;; which isn't actually needed now, in case it is needed later.
    (SETQ SCREEN-LINE-ARRAY (MAKE-ARRAY (1+ HEIGHT-IN-LINES)))
    (SETQ OLD-SCREEN-LINE-ARRAY (MAKE-ARRAY HEIGHT-IN-LINES))
    (SETQ LAST-COL-TO-SAVE+1 WIDTH)
    (SETQ SAVED-LINE-ARRAY (MAKE-ARRAY LINE-LABEL-MAX))
    (SETQ REDISPLAY-STRING (MAKE-ARRAY WIDTH ':TYPE ART-FAT-STRING ':LEADER-LENGTH 1))
    (DOTIMES (I (1+ HEIGHT-IN-LINES))
      (SETF (AREF SCREEN-LINE-ARRAY I)
            (MAKE-ARRAY WIDTH ':TYPE ART-FAT-STRING ':LEADER-LENGTH 3))
      (SETF (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY I) 0) WIDTH))))

(DEFMETHOD (RECORDING-SUPDUP :AFTER :INIT) (&REST IGNORE)
  (SEND SELF ':CHANGE-OF-SIZE-OR-MARGINS))

;This is what the recording supdup puts in a character position
;to record the fact that a %TDTSP was used to space over that position.
;We use code 211 so that its word-syntax will be correct.
(DEFVAR TAB-PLACEHOLDER 211)

;;;Dispatch table for the %TD codes.
(DEFVAR REC-SUPDUP-%TD-DISPATCH (MAKE-ARRAY 100))
(FILLARRAY REC-SUPDUP-%TD-DISPATCH
   '(SUPDUP-TDMOV SUPDUP-TDMV0 REC-SUPDUP-EOF REC-SUPDUP-EOL REC-SUPDUP-DLF
;;;  %TDMOV       %TDMV0       %TDEOF         %TDEOL         %TDDLF

     SUPDUP-NOTHING SUPDUP-GT40 REC-SUPDUP-CRLF SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING
;;;  %TDMTF         %TDMTN      %TDCRL          %TDNOP         %TDBS          %TDLF

     SUPDUP-NOTHING SUPDUP-TDORS SUPDUP-TDQOT TV:SHEET-SPACE SUPDUP-TDMV0 REC-SUPDUP-CLEAR
;;;  %TDCR          %TDORS       %TDQOT       %TDFS          %TDMV0       %TDCLR

     SUPDUP-BEEP    SUPDUP-NOTHING REC-SUPDUP-INSERT-LINE REC-SUPDUP-DELETE-LINE
;;;  %TDBEL         %TDINI         %TDILP                 %TDDLP

     REC-SUPDUP-INSERT-CHAR REC-SUPDUP-DELETE-CHAR SUPDUP-TDBOW SUPDUP-RESET SUPDUP-GRAPHICS
;;;  %TDICP                 %TDDCP                 %TDBOW         %TDRST       %TDGRF

     REC-SUPDUP-REGION-UP REC-SUPDUP-REGION-DOWN
;;;  %TDRSU             %TDRSD

;;; PTV compatibility hacks (ARDS, etc.)
     SUPDUP-NOTHING SUPDUP-ARDS-SET
;;;  %TDGXT         %TDLNG

     SUPDUP-ARDS-LONG   SUPDUP-ARDS-SHORT
;;;  %TDLV              %TDSV

     L-E-SUPDUP-RESYNCH-REPLY-RECEIVED
;;;  %TDSYN

     L-E-SUPDUP-ALLOW-LOCAL-EDITING
;;;  %TDECO

     L-E-SUPDUP-DEFINE-COMMAND
;;;  %TDEDF

     L-E-SUPDUP-STOP-LOCAL-EDITING
;;;  %TDNLE

     REC-SUPDUP-SPACE-FOR-TAB
;;;  %TDTSP

     REC-SUPDUP-LINE-BEG-CONTINUED REC-SUPDUP-LINE-END-CONTINUED
;;;  %TDCTB                        %TDCTE

     REC-SUPDUP-MULTI-POS-CHAR
;;;  %TDMLT

     REC-SUPDUP-SAVE-LINES REC-SUPDUP-RESTORE-LINES
;;;  %TDSVL                %TDSVL

     REC-SUPDUP-SET-SAVING-RANGE REC-SUPDUP-SET-LOCAL-LABEL
;;;  %TDSSR                      %TDSLL
     ))

(DEFMETHOD (RECORDING-SUPDUP :BUFFERED-TYO) (CH &AUX LINE)
  (COND ((< CH #o200)
         (SETF (AREF (SETQ LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) CURRENT-XPOS)
               CH)
         (INCF CURRENT-XPOS)
         ;; Prevent errors storing past end of line
         ;; if remote site sends garbage.
         (AND (= CURRENT-XPOS (ARRAY-LENGTH LINE))
              (DECF CURRENT-XPOS))
         ;; Use top 8 bits of char to indicate start and end
         ;; of multi-position chars.
         ;; Put in 1 for 1st char, 2 for remaining chars.
         (AND (= CURRENT-XPOS MULTI-POS-CHAR-END)
              (DO ((I MULTI-POS-CHAR-BEG (1+ I)))
                  ((= I MULTI-POS-CHAR-END))
                (INCF (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) I)
                      (IF (= I MULTI-POS-CHAR-BEG)
                          #o400 #o1000))))
         ;; Output below the screen bottom is just for recording.
         ;; Don't try to put the characters up-- it would bomb out.
         (OR ( CURRENT-YPOS HEIGHT-IN-LINES)
             (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
               (SEND SELF ':FORCE-OUTPUT))))
        (T
         (SEND SELF ':FORCE-OUTPUT)
         (SETQ MULTI-POS-CHAR-BEG 0 MULTI-POS-CHAR-END 0)
         (OR ( (SETQ CH (- CH 200)) (ARRAY-LENGTH REC-SUPDUP-%TD-DISPATCH))
             (SEND (AREF REC-SUPDUP-%TD-DISPATCH CH) SELF))
         (SETQ CURRENT-XPOS (TRUNCATE (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF))
                                      TV:CHAR-WIDTH)
               CURRENT-YPOS (TRUNCATE (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF))
                                      TV:LINE-HEIGHT)))))

(DEFUN REC-SUPDUP-EOF (WINDOW)
  (REC-SUPDUP-EOF-1 WINDOW)
  (TV:SHEET-CLEAR-EOF WINDOW))

(DEFUN REC-SUPDUP-EOF-1 (WINDOW &OPTIONAL REGION-END)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (OR REGION-END (SETQ REGION-END (1+ HEIGHT-IN-LINES)))
  (REC-SUPDUP-EOL-1 WINDOW)
  (DO ((I (1+ CURRENT-YPOS) (1+ I)))
      ((= I REGION-END))
    (SETF (SCREEN-LINE-BEG-CONTINUED I) NIL)
    (SETF (SCREEN-LINE-END-CONTINUED I) NIL)
    (FILLARRAY (AREF SCREEN-LINE-ARRAY I) '(#/RETURN))))

(DEFUN REC-SUPDUP-EOL (WINDOW)
  (REC-SUPDUP-EOL-1 WINDOW)
  (TV:SHEET-CLEAR-EOL WINDOW))

(DEFUN REC-SUPDUP-EOL-1 (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (SETF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
  (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
    (DO ((XPOS CURRENT-XPOS (1+ XPOS))
         (END (ARRAY-LENGTH LINE)))
        ((= XPOS END))
      (SETF (AREF LINE XPOS) #/RETURN))))

(DEFUN REC-SUPDUP-CRLF (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (TV:SHEET-CRLF WINDOW)
  (SETQ CURRENT-XPOS (TRUNCATE (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF))
                               TV:CHAR-WIDTH)
        CURRENT-YPOS (TRUNCATE (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF))
                               TV:LINE-HEIGHT))
  (REC-SUPDUP-EOL-1 WINDOW))

;;; It is ok to store #/RETURN into the erased char unconditionally
;;; because EMACS only uses this when it is about to
;;; write something into the cleared positions.
(DEFUN REC-SUPDUP-DLF (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
    (SETF (AREF LINE CURRENT-XPOS) #/RETURN))
    (TV:SHEET-CLEAR-CHAR WINDOW))

(DEFUN REC-SUPDUP-SPACE-FOR-TAB (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (SETF (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) CURRENT-XPOS) TAB-PLACEHOLDER)
  (TV:SHEET-SPACE WINDOW))

(DEFUN REC-SUPDUP-CLEAR (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET-GLOBALLY ((CURRENT-XPOS 0) (CURRENT-YPOS 0))     ;was LET
    (REC-SUPDUP-EOF-1 WINDOW))
  (TV:SHEET-CLEAR WINDOW)
  (FILLARRAY GT40-DISPLAY-LIST '(NIL)))         ;Miracle of modularity

(DEFUN REC-SUPDUP-INSERT-LINE (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET ((N-LINES (NVT-NETI)))
    (LET-GLOBALLY ((CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES))   ;was LET
                   (CURRENT-XPOS 0))
      (REC-SUPDUP-EOF-1 WINDOW))
    (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY CURRENT-YPOS
                        (- HEIGHT-IN-LINES N-LINES)
                        SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES)
                        HEIGHT-IN-LINES)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        (- HEIGHT-IN-LINES N-LINES)
                        HEIGHT-IN-LINES
                        SCREEN-LINE-ARRAY
                        CURRENT-YPOS (+ CURRENT-YPOS N-LINES))
    (TV:SHEET-INSERT-LINE WINDOW N-LINES)))

(DEFUN REC-SUPDUP-DELETE-LINE (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET ((N-LINES (NVT-NETI)))
    (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES)
                        HEIGHT-IN-LINES
                        SCREEN-LINE-ARRAY CURRENT-YPOS
                        (- HEIGHT-IN-LINES N-LINES))
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        CURRENT-YPOS (+ CURRENT-YPOS N-LINES)
                        SCREEN-LINE-ARRAY
                        (- HEIGHT-IN-LINES N-LINES)
                        HEIGHT-IN-LINES)
    (LET-GLOBALLY ((CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES))   ;was LET
                   (CURRENT-XPOS 0))
      (REC-SUPDUP-EOF-1 WINDOW))
    (TV:SHEET-DELETE-LINE WINDOW N-LINES)))

(DEFUN REC-SUPDUP-REGION-DOWN (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET* ((REGION-HEIGHT (NVT-NETI))
         (N-LINES (NVT-NETI))
         (REGION-END (+ REGION-HEIGHT CURRENT-YPOS)))
    (LET-GLOBALLY ((CURRENT-YPOS (- REGION-END N-LINES))        ;was LET
                   (CURRENT-XPOS 0))
      (REC-SUPDUP-EOF-1 WINDOW REGION-END))
    (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        CURRENT-YPOS (- REGION-END N-LINES)
                        SCREEN-LINE-ARRAY
                        (+ CURRENT-YPOS N-LINES) REGION-END)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        (- REGION-END N-LINES) REGION-END
                        SCREEN-LINE-ARRAY
                        CURRENT-YPOS (+ CURRENT-YPOS N-LINES))
    (SUPDUP-REGION-DOWN WINDOW REGION-HEIGHT N-LINES)))

(DEFUN REC-SUPDUP-REGION-UP (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET* ((REGION-HEIGHT (NVT-NETI))
         (N-LINES (NVT-NETI))
         (REGION-END (+ CURRENT-YPOS REGION-HEIGHT)))
    (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY)
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        (+ CURRENT-YPOS N-LINES) REGION-END
                        SCREEN-LINE-ARRAY
                        CURRENT-YPOS (- REGION-END N-LINES))
    (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY
                        CURRENT-YPOS (+ CURRENT-YPOS N-LINES)
                        SCREEN-LINE-ARRAY
                        (- REGION-END N-LINES) REGION-END)
    (LET-GLOBALLY ((CURRENT-YPOS (- REGION-END N-LINES))        ;was LET
                   (CURRENT-XPOS 0))
      (REC-SUPDUP-EOF-1 WINDOW REGION-END))
    (SUPDUP-REGION-UP WINDOW REGION-HEIGHT N-LINES)))

(DEFUN REC-SUPDUP-INSERT-CHAR (WINDOW &OPTIONAL COUNT)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (OR COUNT (SETQ COUNT (NVT-NETI)))
  (TV:SHEET-INSERT-CHAR WINDOW COUNT)
  (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
    (DO ((I (1- (ARRAY-LENGTH LINE)) (1- I)))
        ((< I CURRENT-XPOS))
      (SETF (AREF LINE I)
            (IF (< (- I COUNT) CURRENT-XPOS)
                #/SPACE
              (AREF LINE (- I COUNT)))))))

(DEFUN REC-SUPDUP-DELETE-CHAR (WINDOW &OPTIONAL COUNT)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (OR COUNT (SETQ COUNT (NVT-NETI)))
  (TV:SHEET-DELETE-CHAR WINDOW COUNT)
  (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
    (DO ((I CURRENT-XPOS (1+ I))
         (END (ARRAY-LENGTH LINE)))
        ((= I END))
      (SETF (AREF LINE I)
            (IF ( (+ I COUNT) END)
                #/RETURN
              (AREF LINE (+ I COUNT)))))))

(DEFUN REC-SUPDUP-REDISPLAY (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (TV:SHEET-CLEAR WINDOW)
  (DO ((I 0 (1+ I))
       (END HEIGHT-IN-LINES)
       LINE-END)
      ((= I END))
    (SEND WINDOW ':SET-CURSORPOS 0 I ':CHARACTER)
    (SETQ LINE-END (STRING-REVERSE-SEARCH-NOT-CHAR #/RETURN (AREF SCREEN-LINE-ARRAY I)))
    (COND (LINE-END
           (COPY-ARRAY-PORTION (AREF SCREEN-LINE-ARRAY I) 0 (1+ LINE-END)
                               REDISPLAY-STRING 0 (1+ LINE-END))
           (SETF (ARRAY-LEADER REDISPLAY-STRING 0) (1+ LINE-END))
           (DO ((XPOS 0 (1+ XPOS)))
               ((> XPOS LINE-END))
             (LET ((CH (LOGAND 377 (AREF REDISPLAY-STRING XPOS))))
               (AND (OR (= CH TAB-PLACEHOLDER)
                        (= CH #/RETURN))
                    (SETF (AREF REDISPLAY-STRING XPOS) #/SPACE))))
           (SEND WINDOW ':STRING-OUT REDISPLAY-STRING))))
  (SEND WINDOW ':SET-CURSORPOS CURRENT-XPOS CURRENT-YPOS ':CHARACTER))

(DEFUN REC-SUPDUP-LINE-BEG-CONTINUED (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (SETF (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS) T))

(DEFUN REC-SUPDUP-LINE-END-CONTINUED (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (SETF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS) T))

(DEFUN REC-SUPDUP-MULTI-POS-CHAR (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (SETQ MULTI-POS-CHAR-BEG CURRENT-XPOS)
  (SETQ MULTI-POS-CHAR-END (+ MULTI-POS-CHAR-BEG (NVT-NETI)))
  (NVT-NETI))

(DEFMETHOD (RECORDING-SUPDUP :ALLOW-LOCAL-EDITING) ()
  NIL)

(DEFMETHOD (RECORDING-SUPDUP :DEFINE-COMMAND) ()
  (NVT-NETI) (NVT-NETI))

(DEFUN REC-SUPDUP-SAVE-LINES (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (LET ((N-LINES (NVT-NETI))
        (LABEL (+ (NVT-NETI) (LSH (NVT-NETI) 7)))
        (HEIGHT (1+ HEIGHT-IN-LINES)))
    (DO ((I CURRENT-YPOS (1+ I))
         (N N-LINES (1- N)))
        ((OR (= I HEIGHT) (<= N 0)))
      (LET ((LINE (AREF SCREEN-LINE-ARRAY I)))
        (OR (AREF SAVED-LINE-ARRAY LABEL)
            (SETF (AREF SAVED-LINE-ARRAY LABEL)
                  (MAKE-ARRAY (ARRAY-LENGTH LINE) ':TYPE ART-STRING)))
        (FILLARRAY (AREF SAVED-LINE-ARRAY LABEL) '(#/RETURN))
        (COPY-ARRAY-PORTION LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1
                            (AREF SAVED-LINE-ARRAY LABEL)
                            FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1))
      (SETQ LABEL (LOGAND (1- LINE-LABEL-MAX) (1+ LABEL))))))

(DEFUN REC-SUPDUP-RESTORE-LINES (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  (LET ((N-LINES (NVT-NETI))
        (LABEL (+ (NVT-NETI) (LSH (NVT-NETI) 7)))
        (HEIGHT (1+ HEIGHT-IN-LINES)))
    (DO ((I CURRENT-YPOS (1+ I))
         (N N-LINES (1- N)))
        ((OR (= I HEIGHT) (<= N 0)))
      (LET ((LINE (AREF SCREEN-LINE-ARRAY I))
            (SAVED-LINE (AREF SAVED-LINE-ARRAY LABEL))
            LINE-END)
        (COND (SAVED-LINE
               (COPY-ARRAY-PORTION SAVED-LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1
                                   LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1)
               ;; Output changes onto screen, unless now off-screen.
               (COND ((< I HEIGHT-IN-LINES)
                      (SEND WINDOW ':SET-CURSORPOS FIRST-COL-TO-SAVE I ':CHARACTER)
                      (TV:SHEET-CLEAR-EOL WINDOW)
                      (SETQ LINE-END (STRING-REVERSE-SEARCH-NOT-CHAR #/RETURN LINE))
                      (COND (LINE-END
                             (COPY-ARRAY-PORTION (AREF SCREEN-LINE-ARRAY I) 0 (1+ LINE-END)
                                                 REDISPLAY-STRING 0 (1+ LINE-END))
                             (SETF (ARRAY-LEADER REDISPLAY-STRING 0) (1+ LINE-END))
                             (DO ((XPOS 0 (1+ XPOS)))
                                 ((> XPOS LINE-END))
                               (LET ((CH (LOGAND 377 (AREF REDISPLAY-STRING XPOS))))
                                 (AND (OR (= CH TAB-PLACEHOLDER)
                                          (= CH #/RETURN))
                                      (SETF (AREF REDISPLAY-STRING XPOS) #/SPACE))))
                             (SEND WINDOW ':STRING-OUT REDISPLAY-STRING))))))))
      (SETQ LABEL (LOGAND (1- LINE-LABEL-MAX) (1+ LABEL))))
    (SEND WINDOW ':SET-CURSORPOS CURRENT-XPOS CURRENT-YPOS ':CHARACTER)))

(DEFUN REC-SUPDUP-SET-SAVING-RANGE (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (SETQ FIRST-COL-TO-SAVE (NVT-NETI))
  (SETQ LAST-COL-TO-SAVE+1 (NVT-NETI)))

;;; No need to support this until we support local handling
;;; of something that can move lines off the screen.
;;; But do pass by the arguments.
(DEFUN REC-SUPDUP-SET-LOCAL-LABEL (WINDOW)
  (DECLARE (:SELF-FLAVOR RECORDING-SUPDUP))
  WINDOW
  (NVT-NETI) (NVT-NETI))

(DEFCONST TOP-BIT #o4000)

(DEFFLAVOR LOCAL-EDITING-SUPDUP
        (INPUT-CHAR-COUNT LAST-RESYNCH-CHAR-COUNT LAST-RESYNCH-CODE
         RESYNCH-REPLY-CODE RESYNCH-REPLY-CHAR-COUNT
         (SEND-RESYNCH-NOW NIL)
         (LOCAL-EDITING-ENABLE NIL)
         (LOCAL-EDIT-METER 0)
         (CHAR-TABLE (MAKE-ARRAY 2000))
         (WORD-SYNTAX-TABLE (MAKE-ARRAY 200 ':TYPE ART-1B))
         (TOP-EDITING-MARGIN 0) (BOTTOM-EDITING-MARGIN 0)
         (LEFT-EDITING-MARGIN 0) (RIGHT-EDITING-MARGIN 0)
         (INSERT-MODE 'INSERT))
        (RECORDING-SUPDUP))

(DEFMETHOD (LOCAL-EDITING-SUPDUP :AFTER :SET-CONNECTION) (&REST IGNORE)
  (SETQ INPUT-CHAR-COUNT 0 LOCAL-EDIT-METER 0 LAST-RESYNCH-CODE NIL
        SEND-RESYNCH-NOW T
        ALLOW-LOCAL-EDITING NIL
        LOCAL-EDITING-ENABLE NIL))

(DEFVAR BEEP-ON-LOCAL-EDIT NIL)

(DEFVAR INPUT-CHAR-IN-SUPDUP-CODE)

;Given a Lispm keyboard character to "send" to the server,
;first we consider processing it locally if that is enabled now.
(DEFMETHOD (LOCAL-EDITING-SUPDUP :NET-OUTPUT-TRANSLATED) (CH)
  (COND ((CONSP CH)
         (SEND SELF ':NET-OUTPUT CH))
        (T
         ;; If we aren't doing local echoing now, but could do it,
         ;; then send a resynch every so often, so that we are never
         ;; more than 200. or so input chars past a resynch
         ;; unless we are already local editing.
         ;; This is so that the #-chars-since-resynch in a %TDSYN
         ;; always fits in one character.

         ;; Send the resynch BEFORE the input char
         ;; so we don't pre-empt TECO output by mistake.
         (COND ((AND ALLOW-LOCAL-EDITING
                     (NOT LOCAL-EDITING-ENABLE)
                     (OR SEND-RESYNCH-NOW
                         (> (- INPUT-CHAR-COUNT LAST-RESYNCH-CHAR-COUNT) 200.)))
                (SEND SELF ':NET-OUTPUT (+ TOP-BIT #/S))
                (COND ((NULL LAST-RESYNCH-CODE)
                       (SETQ LAST-RESYNCH-CODE 40))
                      ((= LAST-RESYNCH-CODE 176)
                       (SETQ LAST-RESYNCH-CODE 40))
                      (T (INCF LAST-RESYNCH-CODE)))
                (SEND SELF ':NET-OUTPUT LAST-RESYNCH-CODE)
                (SETQ LAST-RESYNCH-CHAR-COUNT INPUT-CHAR-COUNT)))
         ;; Translate char to SUPDUP char set and send it.
         (LET* ((CHAR (CHAR-CODE CH))
                (INPUT-CHAR-IN-SUPDUP-CODE
                  (LOGIOR (LSH (CHAR-BITS CH) 7)
                          (COND ((= CHAR #o33) CHAR)    ;(Special case)
                                ((< CHAR #o40) (LOGIOR CHAR #o4000))
                                ((< CHAR #o177) CHAR)
                                (T (AREF SUPDUP-KEYS (- CHAR #o177)))))))
           (AND LOCAL-EDITING-ENABLE
                (< INPUT-CHAR-IN-SUPDUP-CODE 1000)
                (IF (FUNCALL (OR (AREF CHAR-TABLE INPUT-CHAR-IN-SUPDUP-CODE) 'NOT-HANDLED)
                             SELF INPUT-CHAR-IN-SUPDUP-CODE)
                    ;; If char has just been echoed here,
                    ;; tell the remote machine that it is a pre-echoed char.
                    (PROGN
                      (AND BEEP-ON-LOCAL-EDIT (BEEP))
                      (INCF LOCAL-EDIT-METER)
                      (AND JOURNAL-STREAM (SEND JOURNAL-STREAM ':STRING-OUT "L:"))
                      (SETQ CURRENT-XPOS (TRUNCATE (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF))
                                                   TV:CHAR-WIDTH)
                            CURRENT-YPOS (TRUNCATE (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF))
                                                   TV:LINE-HEIGHT))
                      (SEND SELF ':NET-OUTPUT (+ TOP-BIT #/E))
                      (SEND SELF ':NET-OUTPUT 1))
                    ;; Any char that can't be echoed here
                    ;; turns off local echo.
                    (SETQ LOCAL-EDITING-ENABLE NIL)))
           (SEND SELF ':NET-OUTPUT INPUT-CHAR-IN-SUPDUP-CODE)
           (AND JOURNAL-STREAM (FORMAT JOURNAL-STREAM "~C " CH)))
         (INCF INPUT-CHAR-COUNT))))

(DEFUN NOT-HANDLED (&REST IGNORE) NIL)

;When the remote machine decides we can do local editing,
;it sends us a %TDSYN based on the last resynch we sent.
;The output process comes here and tells the input process
;to go ahead and do local editing (LOCAL-EDITING-ENABLE <- T).
;Local editing stops when LOCAL-EDITING-ENABLE becomes NIL again.
;This can be because the input process sees something it can't handle locally,
;or it can be because more output arrives from the remote machine.
;In the latter case, we assume we are talking to a different program
;which does not understand the local editing protocol, so we turn
;off the use of it, until further notice is received.

;If we receive a resynch reply when we are not expecting one,
;or we get a mismatched reply, then we set flags to send another
;resynch in the hope of unconfusing the other side.
(DEFUN L-E-SUPDUP-RESYNCH-REPLY-RECEIVED (WINDOW)
  WINDOW
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    (COND (ALLOW-LOCAL-EDITING
           (SETQ RESYNCH-REPLY-CODE (NVT-NETI)
                 RESYNCH-REPLY-CHAR-COUNT (+ (NVT-NETI) LAST-RESYNCH-CHAR-COUNT))
           (AND JOURNAL-STREAM (PRINC "Resynch: " JOURNAL-STREAM))
           (IF (AND LAST-RESYNCH-CODE
                    (= RESYNCH-REPLY-CODE LAST-RESYNCH-CODE)
                    (= RESYNCH-REPLY-CHAR-COUNT INPUT-CHAR-COUNT))
               (LET-GLOBALLY ((LOCAL-EDITING-ENABLE T))
                 (AND JOURNAL-STREAM (PRINC "Enable: " JOURNAL-STREAM))
                 (PROCESS-WAIT "LOCAL EDIT"
                               #'(LAMBDA (LOC -STREAM-)
                                   (IF (OR (NOT (CDR LOC))
                                           (LET ((CH (SEND -STREAM- ':TYI-NO-HANG)))
                                             (AND CH (SEND -STREAM- ':UNTYI CH))
                                             CH))
                                       T))
                               (FOLLOW-CELL-FORWARDING
                                 (VALUE-CELL-LOCATION LOCAL-EDITING-ENABLE) T)
                               STREAM)
                 (AND LOCAL-EDITING-ENABLE
                      (SETQ ALLOW-LOCAL-EDITING NIL)))
               (PROGN (AND JOURNAL-STREAM
                           (FORMAT JOURNAL-STREAM "~D ~D ~D ~D "
                                   LAST-RESYNCH-CODE
                                   RESYNCH-REPLY-CODE
                                   RESYNCH-REPLY-CHAR-COUNT
                                   INPUT-CHAR-COUNT))
                      (SETQ SEND-RESYNCH-NOW T))))
          (T (NVT-NETI) (NVT-NETI)
             (SEND WINDOW ':ALLOW-LOCAL-EDITING)))))

;This is where we process a %TDECO, which says that we should
;start attempting to use the local editing protocol
;by sending resynchs from time to time.
(DEFUN L-E-SUPDUP-ALLOW-LOCAL-EDITING (WINDOW)
  (SEND WINDOW ':ALLOW-LOCAL-EDITING))

(DEFUN L-E-SUPDUP-STOP-LOCAL-EDITING (WINDOW)
  (SEND WINDOW ':STOP-LOCAL-EDITING))

(DEFMETHOD (LOCAL-EDITING-SUPDUP :ALLOW-LOCAL-EDITING) ()
  (SETQ ALLOW-LOCAL-EDITING T)
  (SETQ SEND-RESYNCH-NOW T))

(DEFMETHOD (LOCAL-EDITING-SUPDUP :STOP-LOCAL-EDITING) ()
  (SETQ ALLOW-LOCAL-EDITING NIL)
  (SETQ LOCAL-EDITING-ENABLE NIL))

(DEFMETHOD (LOCAL-EDITING-SUPDUP :GOBBLE-GREETING) ()
  (SEND-TTY-VARIABLES STREAM SELF T OVERPRINT)
  (SEND-FINGER-STRING STREAM)
  ;;Print out the greeting message ITS sends in ASCII.
  (DO ((CH #/CR (SEND STREAM ':TYI)))
      ((OR (NULL CH) (= CH 210)))       ;The end is marked with a %TDNOP, NIL is eof
    (AND (< CH 40) (SETQ CH (+ 200 CH)))
    (OR (= CH 212)                      ;Don't type linefeeds (ITS sends CRLFs).
        (TYO CH SELF))))

;;;; Editing commands for local-editing-supdup.

;;;%TDEDF nn specifies what a certain character should do, for local editing.
;;;nn represents two 7-bit characters of information, which are merged into
;;;a 14-bit number, which is then divided into its top 5 bits (the function code)
;;;and its bottom 9 bits (which are the character, in SUPDUP code, whose
;;;meaning is being defined).

;;;These are the function codes:

;;; 0 -- random (no remote echo possible)
;;; 1 -- fwd char
;;; 2 -- back char
;;; 3 -- fwd delete
;;; 4 -- back delete
;;; 5 -- back char, no tabs
;;; 6 -- back delete, no tabs
;;; 7 -- self insert or replace
;;; 10 - vert. up.
;;; 11 - vert down.
;;; 12 - vert up, no tabs
;;; 13 - vert down, no tabs
;;; 14 - up to line beginning
;;; 15 - down to line beginning
;;; 16 - insert CRLF after point
;;; 17 - insert CRLF before point
;;; 20 - beg of line
;;; 21 - end of line
;;; 22 - equivalence to another character's definition.
;;;      A char whose low 7 bits are lower case
;;;      equivs to the corresponding upper case char.
;;;      Any other char which has the control bit
;;;      equivs to the char with bits 300 cleared out
;;;      (control-I and control-Tab both go to Tab).
;;; 23 - fwd word
;;; 24 - back word
;;; 25 - fwd del word
;;; 26 - back del word
;;; 27 - arg digit
;;; 30 - begins arg, followed by digits
;;; 31 - specify word syntax of associated character.
;;;      Since only 7-bit chars have a word syntax, the 200 bit is used
;;;      to say what the syntax is: 1 means the character is a separator.
;;; 32 - specify insert vs replace for chars with definition code 7.
;;;      The arg for this command (what is supplied as the "character
;;;      to be defined") says what to do with all characters whose
;;;      definition code is 7.
;;;      An arg of 0 means they cannot be handled at all.
;;;      An arg of 1 means they insert.  2 means they replace.
;;; 33 - reset all characters to an initial state:
;;;      All characters 40 to 176 self-insert except l.c. letters,
;;;      L.c. letters with any combination of control/meta are equivalenced,
;;;      Digits with control and/or meta are are digits,
;;;      All other characters defined as NIL.
;;;      Syntax table: digits and letters (both cases) make up words.
;;;      Insert mode.
;;;      Margins all zero.
;;; 34 - specify right, left, top or bottom margin
;;;      outside of which any text that appears is not text to be edited.
;;;      The "ASCII character" is the margin value.
;;;      The control/meta bits say which margin to set:
;;;      0 - left   1 - top   2 - right   3 - bottom.

(DEFVAR DEFINITION-CODE-TABLE (MAKE-ARRAY 40))
(FILLARRAY DEFINITION-CODE-TABLE
           `(NIL L-E-SUPDUP-FORWARD-CHAR L-E-SUPDUP-BACKWARD-CHAR
             L-E-SUPDUP-FORWARD-DELETE-CHAR L-E-SUPDUP-BACKWARD-DELETE-CHAR
             L-E-SUPDUP-BACKWARD-CHAR-NO-TABS L-E-SUPDUP-BACKWARD-DELETE-CHAR-NO-TABS
             L-E-SUPDUP-INSERT-CHAR
             NIL NIL
;            L-E-SUPDUP-VERTICALLY-UP L-E-SUPDUP-VERTICALLY-DOWN
             NIL NIL
;            L-E-SUPDUP-VERTICALLY-UP-NO-TABS L-E-SUPDUP-VERTICALLY-DOWN-NO-TABS
             NIL NIL
;            L-E-SUPDUP-UP-TO-LINE-BEG L-E-SUPDUP-DOWN-TO-LINE-BEG
             NIL NIL
;            L-E-SUPDUP-CRLF-AFTER-POINT L-E-SUPDUP-CRLF-BEFORE-POINT
             L-E-SUPDUP-BEG-OF-LINE L-E-SUPDUP-END-OF-LINE
             L-E-SUPDUP-EQUIVALENCE
             L-E-SUPDUP-FORWARD-WORD L-E-SUPDUP-BACKWARD-WORD
             L-E-SUPDUP-FORWARD-KILL-WORD L-E-SUPDUP-BACKWARD-KILL-WORD
             NIL NIL
;            L-E-SUPDUP-ARG-DIGIT L-E-SUPDUP-ARG-STARTER
             (L-E-SUPDUP-SET-WORD-SYNTAX) (L-E-SUPDUP-SET-INSERT-MODE)
             (L-E-SUPDUP-INITIALIZE)
             (L-E-SUPDUP-SET-MARGIN)
             NIL))

(DEFUN L-E-SUPDUP-DEFINE-COMMAND (WINDOW)
  (SEND WINDOW ':DEFINE-COMMAND-CHARACTER))

;Process one %TDEDF.
(DEFMETHOD (LOCAL-EDITING-SUPDUP :DEFINE-COMMAND-CHARACTER) ()
  (LET* ((ARG (+ (LSH (NVT-NETI) 7) (NVT-NETI)))
         (CH (LDB 0011 ARG))
         (CODE (LDB 1105 ARG))
         (DEFN (AREF DEFINITION-CODE-TABLE CODE)))
    (IF (ATOM DEFN)
        (SETF (AREF CHAR-TABLE CH) DEFN)
        (SEND (CAR DEFN) CH))))

(DEFUN L-E-SUPDUP-INITIALIZE (IGNORE)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    (FILLARRAY CHAR-TABLE '(NIL))
    (DO ((I 40 (1+ I)))
        ((= I 177))
      (SETF (AREF CHAR-TABLE I) 'L-E-SUPDUP-INSERT-CHAR))
    (DO ((I #/a (1+ I)))
        ((> I #/z))
      (SETF (AREF CHAR-TABLE I) 'L-E-SUPDUP-EQUIVALENCE)
      (SETF (AREF CHAR-TABLE (+ I 200)) 'L-E-SUPDUP-EQUIVALENCE)
      (SETF (AREF CHAR-TABLE (+ I 400)) 'L-E-SUPDUP-EQUIVALENCE)
      (SETF (AREF CHAR-TABLE (+ I 600)) 'L-E-SUPDUP-EQUIVALENCE))
;    (DO ((I #/0 (1+ I)))
;       ((> I #/9))
;      (SETF (AREF CHAR-TABLE (+ I 200)) 'L-E-SUPDUP-ARG-DIGIT)
;      (SETF (AREF CHAR-TABLE (+ I 400)) 'L-E-SUPDUP-ARG-DIGIT)
;      (SETF (AREF CHAR-TABLE (+ I 600)) 'L-E-SUPDUP-ARG-DIGIT))
    (FILLARRAY WORD-SYNTAX-TABLE '(0))
    (DO ((I #/A (1+ I)))
        ((> I #/Z))
      (SETF (AREF WORD-SYNTAX-TABLE I) 1)
      (SETF (AREF WORD-SYNTAX-TABLE (+ I 40)) 1))
    (DO ((I #/0 (1+ I)))
        ((> I #/9))
      (SETF (AREF WORD-SYNTAX-TABLE I) 1))
    (SETQ INSERT-MODE 'INSERT)
    (SETQ LEFT-EDITING-MARGIN 0
          TOP-EDITING-MARGIN 0
          RIGHT-EDITING-MARGIN 0
          BOTTOM-EDITING-MARGIN 0)))

(DEFUN L-E-SUPDUP-SET-WORD-SYNTAX (CH)
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  (SETF (AREF WORD-SYNTAX-TABLE (LDB 0007 CH))
        (LDB #o0701 CH)))

(DEFUN L-E-SUPDUP-SET-INSERT-MODE (CH)
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  (SETQ INSERT-MODE
        (SELECTQ CH
          (1 'INSERT)
          (2 'REPLACE))))

(DEFUN L-E-SUPDUP-SET-MARGIN (CH)
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  (SET (NTH (LDB #o0702 CH) '(LEFT-EDITING-MARGIN
                             TOP-EDITING-MARGIN
                             RIGHT-EDITING-MARGIN
                             BOTTOM-EDITING-MARGIN))
       (LDB #o0007 CH)))

;;; Return T if there is a tab in the current line after the cursor.
(DEFUN L-E-SUPDUP-TAB-CHECK ()
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
    (%STRING-SEARCH-CHAR TAB-PLACEHOLDER LINE
                         CURRENT-XPOS
                         (ARRAY-LENGTH LINE))))

(DEFUN L-E-SUPDUP-FORWARD-CHAR (WINDOW CH)
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  CH
  (LET ((BUFFER-CHAR (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) CURRENT-XPOS)))
    (IF ( CURRENT-XPOS (- (ARRAY-LENGTH (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
                           1
                           RIGHT-EDITING-MARGIN))
        NIL
      (IF (LDB-TEST 1010 BUFFER-CHAR) NIL
        (SELECT BUFFER-CHAR
          (#/RETURN NIL)
          (TAB-PLACEHOLDER NIL)                 ;a tab.
          (T (SEND WINDOW ':SET-CURSORPOS (1+ CURRENT-XPOS) CURRENT-YPOS ':CHARACTER)
             T))))))

(DEFUN L-E-SUPDUP-BACKWARD-CHAR-NO-TABS (WINDOW CH)
  (L-E-SUPDUP-BACKWARD-CHAR WINDOW CH T))

(DEFUN L-E-SUPDUP-BACKWARD-CHAR (WINDOW CH &OPTIONAL NO-TABS)
  (DECLARE (:SELF-FLAVOR LOCAL-EDITING-SUPDUP))
  CH
  (COND (( CURRENT-XPOS LEFT-EDITING-MARGIN) NIL)
        (T
         (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
                (PREV-CHAR (AREF LINE (- CURRENT-XPOS 1))))
           (COND ((LDB-TEST #o1010 PREV-CHAR) NIL)
                 ((AND (NOT NO-TABS)
                       (= PREV-CHAR TAB-PLACEHOLDER))
                  NIL)
                 (T (SEND WINDOW ':SET-CURSORPOS (1- CURRENT-XPOS) CURRENT-YPOS ':CHARACTER)))))))

(DEFUN L-E-SUPDUP-FORWARD-DELETE-CHAR (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           (BUFFER-CHAR (AREF LINE CURRENT-XPOS)))
      (IF (LDB-TEST 1010 BUFFER-CHAR) NIL
          (SELECT BUFFER-CHAR
            (#/RETURN NIL)
            (TAB-PLACEHOLDER NIL)               ;a tab.
            (T (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
                     ((L-E-SUPDUP-TAB-CHECK) NIL)
                     (T
                      (REC-SUPDUP-DELETE-CHAR WINDOW 1)
                      T))))))))

(DEFUN L-E-SUPDUP-BACKWARD-DELETE-CHAR-NO-TABS (WINDOW CH)
  (L-E-SUPDUP-BACKWARD-DELETE-CHAR WINDOW CH T))

(DEFUN L-E-SUPDUP-BACKWARD-DELETE-CHAR (WINDOW CH &OPTIONAL NO-TABS)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (COND ((<= CURRENT-XPOS LEFT-EDITING-MARGIN) NIL)
          ((L-E-SUPDUP-TAB-CHECK) NIL)
          ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
          (T
           (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
                  (PREV-CHAR (IF (AND (= CURRENT-XPOS (1+ LEFT-EDITING-MARGIN))
                                      (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS))
                                 -1
                                 (AREF LINE (- CURRENT-XPOS 1)))))
             (COND ((LDB-TEST 1010 PREV-CHAR) NIL)
                   ((AND (NOT NO-TABS)
                         (= PREV-CHAR TAB-PLACEHOLDER))
                    NIL)
                   (T
                    (SEND WINDOW ':SET-CURSORPOS
                             (SETQ CURRENT-XPOS (1- CURRENT-XPOS))
                             CURRENT-YPOS ':CHARACTER)
                    (REC-SUPDUP-DELETE-CHAR WINDOW 1)
                    T)))))))

(DEFUN L-E-SUPDUP-INSERT-CHAR (WINDOW IGNORE &AUX CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    (SETQ CH (LOGAND 177 INPUT-CHAR-IN-SUPDUP-CODE))
    (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           (END-XPOS (1+ (OR (STRING-REVERSE-SEARCH-NOT-CHAR #/RETURN LINE) -1))))
      (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
            ((= END-XPOS (- (ARRAY-LENGTH LINE) 1)) NIL)
            ((NULL INSERT-MODE) NIL)
            ((L-E-SUPDUP-TAB-CHECK) NIL)
            ((OR (EQ INSERT-MODE 'INSERT)
                 (= END-XPOS CURRENT-XPOS))
             (REC-SUPDUP-INSERT-CHAR WINDOW 1)
             (SEND WINDOW ':BUFFERED-TYO CH)
             (SEND WINDOW ':FORCE-OUTPUT)
             T)
            ((NOT (LDB-TEST 1010 (AREF LINE CURRENT-XPOS)))
             (REC-SUPDUP-DLF WINDOW)
             (SEND WINDOW ':BUFFERED-TYO CH)
             (SEND WINDOW ':FORCE-OUTPUT)
             T)))))

(DEFUN L-E-SUPDUP-BEG-OF-LINE (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (COND ((ZEROP CURRENT-YPOS) NIL)
          ((SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS) NIL)
          (T (SEND WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER)
             T))))

(DEFUN L-E-SUPDUP-END-OF-LINE (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           (END-XPOS (OR (STRING-REVERSE-SEARCH-NOT-CHAR #/RETURN LINE) -1)))
      (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
            (T (SEND WINDOW ':SET-CURSORPOS (1+ END-XPOS) CURRENT-YPOS ':CHARACTER)
               T)))))

(DEFUN L-E-SUPDUP-EQUIVALENCE (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    (PROG (NEW-CH)
      (COND ((= (LOGAND CH 140) 140) (SETQ NEW-CH (LOGXOR CH 40)))
            ;; If control bit is present, clear it and also alphabetic bit.
            ((= (LOGAND CH 200) 200) (SETQ NEW-CH (LOGAND CH 477)))
            (T (RETURN NIL)))
      (RETURN (SEND (OR (AREF CHAR-TABLE NEW-CH) 'NOT-HANDLED) WINDOW NEW-CH)))))

(DEFUN L-E-SUPDUP-FORWARD-WORD (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET (FOUND-WORD
          (LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)))
      (DO ((I CURRENT-XPOS (1+ I))
           (END (IF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS)
                    (1- (ARRAY-LENGTH LINE))
                    (ARRAY-LENGTH LINE))))
          ((= I END) NIL)
        (LET ((CHAR (AREF LINE I)))
          (COND ((LDB-TEST 1010 CHAR) (RETURN NIL))
                ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE
                                   (SETQ CHAR (LDB 0007 CHAR)))))
                 (SETQ FOUND-WORD T))
                ;; Is this a separator reached after we passed a word?
                (FOUND-WORD
                 (SEND WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER)
                 (RETURN T))))))))

(DEFUN L-E-SUPDUP-BACKWARD-WORD (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           FOUND-WORD)
      (DO ((I CURRENT-XPOS (1- I)))
          ((= I 0)
           ;; If we reach the beginning of the line,
           ;; that is a fine stopping place for the word
           ;; as long as the previous lineis not continued.
           (AND (NOT (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS))
                FOUND-WORD
                (PROGN (SEND WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER)
                       T)))

        (AND (LDB-TEST 1010 (AREF LINE (1- I)))
             (RETURN NIL))
        (COND ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (LDB 0007 (AREF LINE (1- I))))))
               (SETQ FOUND-WORD T))
              (FOUND-WORD
               (SEND WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER)
               (RETURN T)))))))

(DEFUN L-E-SUPDUP-FORWARD-KILL-WORD (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET* (FOUND-WORD
           (LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           (END (ARRAY-LENGTH LINE)))
      (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL)
            ((L-E-SUPDUP-TAB-CHECK) NIL)
            (T (DO ((I CURRENT-XPOS (1+ I)))
                   ((= I END) NIL)
                 (LET ((CHAR (AREF LINE I)))
                   (COND ((LDB-TEST 1010 CHAR) (RETURN NIL))
                         ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE
                                            (SETQ CHAR (LDB 0007 CHAR)))))
                          (SETQ FOUND-WORD T))
                         ;; Is this a separator reached after we passed a word?
                         (FOUND-WORD
                          (REC-SUPDUP-DELETE-CHAR WINDOW (- I CURRENT-XPOS))
                          (RETURN T))))))))))

(DEFUN L-E-SUPDUP-BACKWARD-KILL-WORD (WINDOW CH)
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP)
    CH
    (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))
           (OLD-XPOS CURRENT-XPOS)
           FOUND-WORD)
      (AND (NOT (SCREEN-LINE-END-CONTINUED CURRENT-YPOS))
           (NOT (L-E-SUPDUP-TAB-CHECK))
           (DO ((I CURRENT-XPOS (1- I)))
               ((= I 0)
                ;; If we reach the beginning of the line,
                ;; that is a fine stopping place for the word
                ;; as long as the previous lineis not continued.
                (AND (> CURRENT-YPOS 0)
                     (NOT (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS))
                     FOUND-WORD
                     (PROGN (SEND WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER)
                            (SETQ CURRENT-XPOS 0)
                            (REC-SUPDUP-DELETE-CHAR WINDOW OLD-XPOS)
                            T)))
             (AND (LDB-TEST 1010 (AREF LINE (1- I)))
                  (RETURN NIL))
             (COND ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (LDB 0007 (AREF LINE (1- I))))))
                    (SETQ FOUND-WORD T))
                   (FOUND-WORD
                    (LET ((OLD-XPOS CURRENT-XPOS))
                      (SEND WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER)
                      (SETQ CURRENT-XPOS I)
                      (REC-SUPDUP-DELETE-CHAR WINDOW (- OLD-XPOS I)))
                    (RETURN T))))))))

(DEFFLAVOR BASIC-TELNET
            ((NEW-TELNET-P NIL)
             (MORE-FLAG NIL)
             (ECHO-FLAG NIL)
             (SIMULATE-IMLAC-FLAG NIL)
             (BINARY-OUTPUT-FLAG NIL)
             (SUPDUP-OUTPUT-FLAG NIL))
            (BASIC-NVT TV:FULL-SCREEN-HACK-MIXIN TV:LIST-MOUSE-BUTTONS-MIXIN)
  (:DEFAULT-INIT-PLIST :PROGRAM-NAME "Telnet")
  (:DOCUMENTATION :SPECIAL-PURPOSE "A TELNET NVT")
  (:SETTABLE-INSTANCE-VARIABLES SIMULATE-IMLAC-FLAG))

(DEFFLAVOR TELNET () (BASIC-TELNET TV:WINDOW)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  (:DOCUMENTATION :COMBINATION))

(DEFUN TELNET (&OPTIONAL PATH (MODE SUPDUP-MODE))
  "Make a TELNET connection to machine specified by PATH.
PATH is a machine name or a string saying how to get to one, such as
<arpanet-gateway><host> or <host>//<contact-name or socket number>
or <gateway><host>//<socket-number>.
If MODE is NIL, TELNET runs in (a window substituting for) this window.
Otherwise a separate TELNET window is selected."
  (IF MODE
      (TELNET-SEPARATE PATH)
      (TELNET-BIND PATH)))

(DEFUN TELNET-SEPARATE (&OPTIONAL PATH &AUX SW)
  "Switch to a non-connected TELNET window and connect it to machine PATH.
If PATH is NIL, a connected TELNET window will be selected if there is one."
  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-TELNET T NIL)))
         (SEND SW ':SELECT)
         NIL)
        (T
         (SETQ SW (OR (FIND-SELECTABLE-TELNET NIL) (TV:MAKE-WINDOW 'TELNET)))
         (SEND SW ':SET-CONNECT-TO (OR PATH SUPDUP-DEFAULT-PATH
                                          SI:ASSOCIATED-MACHINE))
         (SEND SW ':EXPOSE NIL ':CLEAN) ;Don't come up with old garbage
         (SEND SW ':SELECT)
         T)))

(DEFVAR TELNET-WINDOWS NIL
  "List of all ordinary non-resource TELNET windows.")

(DEFUN FIND-SELECTABLE-TELNET (CONNECTED-P &OPTIONAL (SUP TV:MOUSE-SHEET))
  (DOLIST (W TELNET-WINDOWS)
    (AND (EQ (SEND W ':CONNECTED-P) CONNECTED-P)
         (OR (NULL SUP) (EQ SUP (TV:SHEET-SUPERIOR W)))
         (RETURN W))))

(TV:DEFWINDOW-RESOURCE TELNET-WINDOWS ()
  :INITIAL-COPIES 0
  :MAKE-WINDOW (TELNET :TYPEIN-PROCESS NIL :TYPEOUT-PROCESS NIL))

(DEFMETHOD (TELNET :BEFORE :SELECT) (&REST IGNORE)
  ;Move ourselves to the head of the list
  (WITHOUT-INTERRUPTS
    (SETQ TELNET-WINDOWS (DELQ SELF TELNET-WINDOWS))
    (PUSH SELF TELNET-WINDOWS)))

(DEFMETHOD (TELNET :BEFORE :DEACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS (SETQ TELNET-WINDOWS (DELQ SELF TELNET-WINDOWS))))

(DEFMETHOD (TELNET :AFTER :ACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS
    (OR (MEMQ SELF TELNET-WINDOWS)
        (IF TELNET-WINDOWS
            (RPLACD (LAST TELNET-WINDOWS) (NCONS SELF))
          (SETQ TELNET-WINDOWS (NCONS SELF))))))

(DEFMETHOD (TELNET :SETUP) (WINDOW IN-P OUT-P SIMULATE-IMLAC)
  (LEXPR-SEND SELF ':SET-EDGES
              (MULTIPLE-VALUE-LIST (SEND WINDOW ':EDGES)))
  (SETQ ALIAS-WINDOW WINDOW)
  (SETQ TYPEOUT-PROCESS OUT-P
        TYPEIN-PROCESS IN-P
        SIMULATE-IMLAC-FLAG SIMULATE-IMLAC)
  (PROCESS-PRESET TYPEOUT-PROCESS SELF ':TYPEOUT-TOP-LEVEL))

(DEFUN TELNET-BIND (&OPTIONAL (PATH SI:ASSOCIATED-MACHINE)
               SIMULATE-IMLAC-P (WINDOW (SEND TERMINAL-IO ':ALIAS-FOR-SELECTED-WINDOWS)))
  "Enter TELNET connection to machine specified by PATH.
SIMULATE-IMLAC-P non-NIL says simulate MIT's PDS-1 display codes.
The I//O is done in a window that overlies the one that is TERMINAL-IO."
  (USING-RESOURCE (TELNET-WINDOW TELNET-WINDOWS)
    (USING-RESOURCE (TP TYPEOUT-PROCESSES)
      (SEND TELNET-WINDOW ':SETUP WINDOW CURRENT-PROCESS TP SIMULATE-IMLAC-P)
      (TV:WITH-SELECTION-SUBSTITUTE (TELNET-WINDOW WINDOW)
        (SEND TELNET-WINDOW ':CONNECT PATH)
        (CATCH-ERROR-RESTART ((SYS:ABORT ERROR) "Exit TELNET.")
          (SEND TELNET-WINDOW ':TYPEIN-TOP-LEVEL NIL))
;       (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
        T))))

(DEFMETHOD (BASIC-TELNET :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3) &AUX CONN)
  (MULTIPLE-VALUE-BIND (HOST GATEWAY CONTACT CONTACT-P)
      (PARSE-PATH PATH "TELNET" 27)
    (SETQ CONN (SEND SELF ':NEW-CONNECTION HOST GATEWAY CONTACT CONTACT-P NET-WINDOW)))
  (IF (ERRORP CONN)
      ;; Lose, return "error code".
      CONN
      ;; Win, request remote echoing.
      (TELNET-ECHO T)))

(DEFMETHOD (BASIC-TELNET :GOBBLE-GREETING) ()
  (TERPRI SELF))

(DEFMETHOD (BASIC-TELNET :AFTER :DISCONNECT) ()
  (SETQ ECHO-FLAG NIL NEW-TELNET-P NIL SUPDUP-OUTPUT-FLAG NIL BINARY-OUTPUT-FLAG NIL)
  (SEND SELF ':SET-LABEL (FORMAT NIL "~A -- not connected" TV:NAME)))

(DEFVAR TELNET-KEYS (MAKE-ARRAY 200 ':TYPE 'ART-16B))
(FILLARRAY TELNET-KEYS #o'(0 100101 100370 100364       ;null break clear call
                           0 37 37 177 10 11 12         ;esc back-next help rubout bs tab lf
                           13 14 15 21 0                ;vt form return quote hold-output
                           100365 100363 0 100366       ;stop-output abort resume status
                           0 0 0 0 0 0 0 0 0 0          ;end ...
                           100101 0))                   ;network

;;;Convert to NVT ASCII (except don't convert CR to two characters).
(DEFMETHOD (BASIC-TELNET :NET-OUTPUT-TRANSLATED) (CH)
  (COND ((CONSP CH)
         (SELECTQ (FIRST CH)
           (:MOUSE-BUTTON (IF SUPDUP-OUTPUT-FLAG
                              (MOUSE-OUT (FOURTH CH) (FIFTH CH) (SECOND CH))))))
        (T
         (LET ((CHAR (LDB %%KBD-CHAR CH)))
           (COND ((NOT ECHO-FLAG)
                  ;; Echo the character.
                  (IF (LDB-TEST %%KBD-CONTROL CH)
                      (SEND SELF ':TYO #/))
                  (SEND SELF ':TYO CHAR)))
           (COND ((AND SUPDUP-OUTPUT-FLAG
                       (= CHAR #/END))
                  (SEND SELF ':NET-OUTPUT 30)   ;control X
                  (SEND SELF ':NET-OUTPUT 23))  ;control S
                 (T
                  (AND (LDB-TEST %%KBD-CONTROL CH) (SETQ CHAR (LDB 0005 CH)))   ;controlify
                  (AND (> CHAR 200) (SETQ CHAR (AREF TELNET-KEYS (- CHAR 200))))
                  (AND (LDB-TEST %%KBD-META CH) (SETQ CHAR (+ CHAR 200)))
                  (SEND SELF ':NET-OUTPUT CHAR)))))))

(defwrapper (basic-telnet :net-output-translated) ((ch) . body)
  `(return (send stream :tyo ch)))

(defwrapper (basic-telnet :net-output) ((ch) . body)
  `(return (send stream :tyo ch)))

(recompile-flavor 'basic-telnet)

(DEFCONST NVT-IP 364)
(DEFCONST NVT-DM 362)
(DEFCONST NVT-IAC 377)
(DEFCONST NVT-DONT 376)
(DEFCONST NVT-DO 375)
(DEFCONST NVT-WONT 374)
(DEFCONST NVT-WILL 373)
(DEFCONST NVT-SUBNEGOTIATION-BEGIN 372)
(DEFCONST NVT-SUBNEGOTIATION-END 360)

(DEFCONST NVT-SUPDUP-OUTPUT 26)
(DEFCONST NVT-TIMING-MARK 6)
(DEFCONST NVT-SUPPRESS-GO-AHEAD 3)
(DEFCONST NVT-ECHO 1)
(DEFCONST NVT-TRANSMIT-BINARY 0)
(DEFCONST NVT-LOGOUT 22)

(DEFMETHOD (BASIC-TELNET :NET-OUTPUT) (CH)
  (LOCK-OUTPUT
    (COND ((LDB-TEST #o1701 CH)
           (AND NEW-TELNET-P (SEND STREAM ':TYO NVT-IAC))
           (SETQ CH (LDB #o0010 CH))))
    (SEND STREAM ':TYO CH)
    (COND ((= CH 15)
           (SEND STREAM ':TYO #o12))            ;CR is two chars
          ((AND (= CH NVT-IAC) NEW-TELNET-P)
           (SEND STREAM ':TYO #o377)))))        ;IAC's must be quoted

(DEFMETHOD (BASIC-TELNET :BUFFERED-TYO) (CH &AUX CH1)
  (COND ((= CH NVT-IAC)
         (SEND SELF ':HANDLE-IAC))              ;Perform new telnet negotiations.
        (( CH #o200))                          ;Ignore otelnet negotiations
        ((AND (= CH 7) (NOT (AND SIMULATE-IMLAC-FLAG BINARY-OUTPUT-FLAG)))
         (SEND SELF ':REMOTE-BEEP))             ;^G rings the bell.
        ((AND (= CH #o15)
              (IF (= (SETQ CH1 (NVT-NETI)) #o12)        ;CR LF is NVT newline "character"
                  NIL                           ;Output normally
                  ;; A CR not followed by a LF.  Move the "carriage" to the start of the
                  ;; current line.  Then if the next character is anything other than a NUL,
                  ;; assume the other end if not obeying protocol and output it too.
                  (SEND SELF ':FORCE-OUTPUT)
                  (MULTIPLE-VALUE-BIND (IGNORE Y) (SEND SELF ':READ-CURSORPOS)
                    (SEND SELF ':SET-CURSORPOS 0 Y))
                  (= (SETQ CH CH1) 0))))        ;If NUL, skip any output
        ((AND (= CH #o177) SIMULATE-IMLAC-FLAG) ;Escape character
         (SEND SELF ':HANDLE-IMLAC-ESCAPE))
        (T
         (AND ( CH #o10) ( CH #o15) ( CH #o13)       ;Convert formatting controls
              (NOT (AND SIMULATE-IMLAC-FLAG BINARY-OUTPUT-FLAG))
              (SETQ CH (+ CH 200)))             ;to Lisp machine char set.
         (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
           (SEND SELF ':FORCE-OUTPUT)))))

;;; New telnet protocol IAC handler
(DEFMETHOD (BASIC-TELNET :HANDLE-IAC) (&AUX COMMAND OPTION)
  (COND ((NULL NEW-TELNET-P)
         (TELNET-SEND-OPTION NVT-DO NVT-ECHO)
         (TELNET-SEND-OPTION NVT-DO NVT-SUPPRESS-GO-AHEAD)
         (SETQ NEW-TELNET-P T)))
  (SETQ COMMAND (NVT-NETI))
  (AND ( COMMAND NVT-WILL) ( COMMAND NVT-DONT)
       (SETQ OPTION (NVT-NETI)))
  (SELECT COMMAND
    (NVT-WILL
     (SELECT OPTION
       (NVT-ECHO
        (TELNET-ECHO T))
       (NVT-SUPPRESS-GO-AHEAD)          ;ignore things we requested
       (NVT-TRANSMIT-BINARY
        (SETQ BINARY-OUTPUT-FLAG T)
        (TELNET-SEND-OPTION NVT-DO OPTION))
       (NVT-SUPDUP-OUTPUT
        (TELNET-START-SUPDUP-OUTPUT))
       (OTHERWISE
        (TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-DO
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO NIL))
           ((OR (= OPTION NVT-SUPPRESS-GO-AHEAD) (= OPTION NVT-TIMING-MARK)
                (= OPTION NVT-TRANSMIT-BINARY))
            (TELNET-SEND-OPTION NVT-WILL OPTION))
           (T (TELNET-SEND-OPTION NVT-WONT OPTION))))
    (NVT-DONT
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T))
           ((= OPTION NVT-TRANSMIT-BINARY)
            (TELNET-SEND-OPTION NVT-WONT OPTION))))
    (NVT-WONT
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO NIL))
           ((= OPTION NVT-TRANSMIT-BINARY)
            (SETQ BINARY-OUTPUT-FLAG NIL)
            (TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-SUBNEGOTIATION-BEGIN
     (TELNET-HANDLE-SUBNEGOTIATION))))

(DEFMETHOD (BASIC-TELNET :HANDLE-IMLAC-ESCAPE) (&AUX CH)
  (SEND SELF ':FORCE-OUTPUT)
  (SETQ CH (+ (NVT-NETI) #o176))
  (COND ((= CH 177)
         (LET-GLOBALLY ((SIMULATE-IMLAC-FLAG NIL))      ;was LET
           (SEND SELF ':BUFFERED-TYO CH)))
        ((< (SETQ CH (- CH #o200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
         (FUNCALL (AREF SUPDUP-%TD-DISPATCH CH) SELF))))

;;; Set our idea of who is echoing, and send a DO or DONT,
;;; unless the state is already this way.
;;; The argument to TELNET-ECHO is the new value of ECHO-FLAG,
;;; which is NIL for local echo (the official default) and T for remote echo.
;;; So (TELNET-ECHO T) means that we want remote echoing.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-ECHO (ON-P)
  (COND ((NEQ ECHO-FLAG ON-P) ;If not the right way already
         (SETQ ECHO-FLAG ON-P)
         (TELNET-SEND-OPTION (IF ON-P NVT-DO NVT-DONT) NVT-ECHO)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-SEND-OPTION (COMMAND OPTION)
  (LOCK-OUTPUT
    (SEND STREAM ':TYO NVT-IAC)
    (SEND STREAM ':TYO COMMAND)
    (SEND STREAM ':TYO OPTION)
    (SEND STREAM ':FORCE-OUTPUT))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-START-SUPDUP-OUTPUT ()
  (SETQ SUPDUP-OUTPUT-FLAG T)
  (LOCK-OUTPUT
    (SEND STREAM ':TYO NVT-IAC)
    (SEND STREAM ':TYO NVT-SUBNEGOTIATION-BEGIN)
    (SEND STREAM ':TYO NVT-SUPDUP-OUTPUT)
    (SEND STREAM ':TYO 1)
    (LET ((SUPDUP-%TOCID T))
      (SEND-TTY-VARIABLES STREAM SELF NIL OVERPRINT))
    (SEND STREAM ':TYO NVT-IAC)
    (SEND STREAM ':TYO NVT-SUBNEGOTIATION-END)
    (SEND STREAM ':FORCE-OUTPUT))))

(DEFUN TELNET-HANDLE-SUBNEGOTIATION ()
  (IF (AND (= (NVT-NETI) NVT-SUPDUP-OUTPUT) (= (NVT-NETI) 2))
      (TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION)
      (DO ((CH) (STATE)) (NIL)
        (SETQ CH (NVT-NETI))
        (COND (STATE
               (AND (= CH NVT-SUBNEGOTIATION-END)
                    (RETURN NIL))
               (SETQ STATE NIL))
              ((= CH NVT-IAC)
               (SETQ STATE T))))))

(DEFUN TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION ()
  (DECLARE (:SELF-FLAVOR BASIC-TELNET))
  (LET ((SUPDUP-OUTPUT-OLD-STREAM STREAM)
        (SUPDUP-OUTPUT-BYTE-COUNT (NVT-NETI)))
    (DECLARE (SPECIAL SUPDUP-OUTPUT-BYTE-COUNT SUPDUP-OUTPUT-OLD-STREAM))
    (BIND (LOCF STREAM) 'SUPDUP-OUTPUT-COUNTING-STREAM)
    (DO ()
        (( SUPDUP-OUTPUT-BYTE-COUNT 0)
         (OR (AND (= SUPDUP-OUTPUT-BYTE-COUNT 0)
                  (NVT-NETI) (NVT-NETI)         ;We already know the cursor position
                  (= (NVT-NETI) NVT-IAC) (= (NVT-NETI) NVT-SUBNEGOTIATION-END))
             (FERROR NIL "SUPDUP-OUTPUT subnegotiation out of phase")))
      (FUNCALL 'SUPDUP-BUFFERED-TYO ':BUFFERED-TYO (NVT-NETI)))))

(DEFUN SUPDUP-OUTPUT-COUNTING-STREAM (OP &REST ARGS)
  (DECLARE (SPECIAL SUPDUP-OUTPUT-BYTE-COUNT SUPDUP-OUTPUT-OLD-STREAM))
  (PROG1 (LEXPR-SEND SUPDUP-OUTPUT-OLD-STREAM OP ARGS)
         (AND (EQ OP ':TYI)
              (SETQ SUPDUP-OUTPUT-BYTE-COUNT (1- SUPDUP-OUTPUT-BYTE-COUNT)))))

(DEFMETHOD (BASIC-TELNET :WHO-LINE-DOCUMENTATION-STRING) ()
  (IF SUPDUP-OUTPUT-FLAG
      "Left: Move point.  Middle: Select buffer.  Right: Get buffer editor."
    "Click right twice for System Menu."))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN MOUSE-OUT (X Y BUTTONS)
  (SEND SELF ':NET-OUTPUT 33)
  (MOUSE-COORD-OUT (TRUNCATE X TV:CHAR-WIDTH))
  (MOUSE-COORD-OUT (TRUNCATE Y TV:LINE-HEIGHT))
  (SEND SELF ':NET-OUTPUT (+ (1+ (LDB 0003 BUTTONS))
                                (IF (NOT (ZEROP (LDB 0303 BUTTONS))) 1 0)
                                #/0))
  (SEND SELF ':NET-OUTPUT #o33)
  (SEND SELF ':NET-OUTPUT #o12))
)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN MOUSE-COORD-OUT (N)
  (SEND SELF ':NET-OUTPUT (+ #/0 (TRUNCATE N 100.)))
  (SETQ N (\ N 100.))
  (SEND SELF ':NET-OUTPUT (+ #/0 (TRUNCATE N 10.)))
  (SETQ N (\ N 10.))
  (SEND SELF ':NET-OUTPUT (+ #/0 N)))
)

(DEFMETHOD (BASIC-TELNET :LOGOUT) ()
  (TELNET-SEND-OPTION NVT-DO NVT-LOGOUT))

(DEFMETHOD (BASIC-TELNET :TOGGLE-IMLAC-SIMULATION) ()
  (SETQ SIMULATE-IMLAC-FLAG (NOT SIMULATE-IMLAC-FLAG)))

(DEFMETHOD (BASIC-TELNET :USER-SET-MORE-P) (NEW-MORE-P)
  (SEND SELF ':SET-MORE-P NEW-MORE-P))

(DEFMETHOD (BASIC-TELNET :MORE-EXCEPTION) ()
  (TV:SHEET-MORE-HANDLER ':MORE-TYI))

(DEFMETHOD (BASIC-TELNET :MORE-TYI) ()
  (SETQ MORE-FLAG T)
  (COND ((EQ CURRENT-PROCESS TYPEOUT-PROCESS)
         (SEND SELF ':FORCE-KBD-INPUT '(:MORE))
         (PROCESS-WAIT "MORE"
                       #'(LAMBDA (LOC) (NOT (CAR LOC)))
                       (LOCATE-IN-INSTANCE SELF 'MORE-FLAG)))
        (T
         (SEND SELF ':ALLOW-ESCAPE)
         (SEND SELF ':TYI)
         (SETQ MORE-FLAG NIL))))

(DEFMETHOD (BASIC-TELNET :SEND-IP) ()
  ;; Send a New Telnet "Interrupt Process".
  (LOCK-OUTPUT
    (SEND STREAM ':FORCE-OUTPUT)
    (LET* ((PKT (CHAOS:GET-PKT))
           (STRING (CHAOS:PKT-STRING PKT)))
      ;; Send a Chaosnet packet with opcode 201 to the ARPA server.  This
      ;; opcode is magic, and means to send a network host-to-host interrupt
      ;; before sending the data in the packet.  We also put a New Telnet
      ;; "Data Mark" into the packet.
      (ASET NVT-IAC STRING 0)
      (ASET NVT-IP STRING 1)
      (ASET NVT-IAC STRING 2)
      (ASET NVT-DM STRING 3)
      (SETF (CHAOS:PKT-NBYTES PKT) 4)
      (CHAOS:SEND-PKT CONNECTION PKT 201))))

(COMMENT

;; assumes instance vars LINE-EDITOR-BUFFER

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT)
(DEFMETHOD READLINE-FOR-NVT ()
    (COND ((NOT RUBOUT-HANDLER)
           ;;Stream with rubouts assumed not to have EOFs
           (SEND STREAM ':RUBOUT-HANDLER '() (FUNCTION READLINE-FOR-NVT) SELF))
          ;; Accumulate a string until CR, ignoring control characters
          (T
           (DO ((IDX 0)
                (LEN (ARRAY-ACTIVE-LENGTH LINE-EDITOR-BUFFER))
                (CH))
               (NIL)
             (SETQ CH (SEND SELF ':TYI))
             (COND ((OR (NULL CH) (= CH #/CR))
                    (RETURN NIL))
                   ((LDB-TEST %%KBD-CONTROL-META CH) )  ;Ignore controls
                   (T (AND (= IDX LEN)
                           (ADJUST-ARRAY-SIZE LINE-EDITOR-BUFFER (SETQ LEN (+ LEN 100))))
                      (ASET CH LINE-EDITOR-BUFFER IDX)
                      (SETQ IDX (1+ IDX))))))))
)

);end COMMENT

(COMPILE-FLAVOR-METHODS SUPDUP TELNET LOCAL-EDITING-SUPDUP)

;;; Always have at least one supdup window in the world
(OR SUPDUP-WINDOWS
    (TV:WITHOUT-SCREEN-MANAGEMENT (SEND (TV:WINDOW-CREATE SUPDUP-FLAVOR) ':ACTIVATE)))
